home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / rbbs_pc / mpl172b.zip / RBBSSUB4.BAS < prev    next >
BASIC Source File  |  1989-09-12  |  127KB  |  3,343 lines
  1. ' $linesize:132
  2. ' $title: 'RBBSSUB4.BAS CPC17.2B, Copyright 1986 - 89 by D. Thomas Mack'
  3. '  Copyright 1989 by D. Thomas Mack, all rights reserved.
  4. '  Name ...............: RBBSSUB4.BAS
  5. '  Written by .........: D. Thomas Mack
  6. '  First Released .....: May 28, 1989
  7. '  Subsequent Releases.: 07-30-89
  8. '  Copyright ..........: 1986 - 1989
  9. '  Purpose.............: The Remote Bulletin Board System for the IBM PC,
  10. '     RBBS-PC.BAS utilizes a lot of common subroutines.  Those that do not
  11. '     require error trapping are incorporated within RBBSSUB 2-5 as
  12. '     separately callable subroutines in order to free up as much
  13. '     code as possible within the 64K code segment used by RBBS-PC.BAS.
  14. '  Parameters..........: Most parameters are passed via a COMMON statement.
  15. '
  16. ' Subroutine  Line               Function of Subroutine
  17. '   Name     Number
  18. '  ANYBUT     59760   Determine where a "word" begins
  19. '  ASKUSERS   64003   Ask users questions based on a script and save answers
  20. '  ASKMORE    59858   Check whether screen full
  21. '  AUTOPAGE   60300   Check whether to notify sysop caller is on
  22. ' BADFILECHAR 59800   Check file name for bad character
  23. '  BRACKET    59960   Puts strings around a substring
  24. '  BUFFILE    58400   Write a file to the user quickly
  25. '  BUFSTRNG   58300   Write a string with imbedded CR/LF to the user quickly
  26. '  CHKCOLOR   59930   Highlighting based on search string
  27. '  CHKNARY    58190   Check for the occurance of a string in an array
  28. '  COLORDIR   59920   Adds colorization to FMS directory entry
  29. '  COLORPMT   59940  Colorizes prompts
  30. '  COMPDATE   59880+  Produces a computational data from YY, MM, DD
  31. '  CONFMAIL   59854   Check conference mail waiting
  32. '  CONVDIRS   58950   Checks for U & A (shorthand) and converts appropriately
  33. '  CSTRDATE   59201   Compress date in string format to 2 characters
  34. '  EOFCOMM    60000   Determine whether any chars in comm port buffer
  35. '  EXPDATE    59890  Calculate registration expiration date
  36. '  FAKEXRPT   62650   Write out file transfer report for protocols that don't
  37. '  FINDEND    58770   Find where a "word" ends
  38. '  FINDFILE   58790   Determine whether a file exists without opening it
  39. '  FINDLAST   58600   Find last occurence of a string
  40. '  FMS        58200   Search the upload management system for entries
  41. '  GETALL     59780   Get list of all directories to display
  42. '  GETDIRS    58895   Prompts for directories for file list/new/search cmds
  43. '  GETMATTR   62530   Restore attributes of original message
  44. '  GETYMD     59204   Pulls YY, MM, or DD from a 2 byte stored date
  45. '  GSANDR     60100   Global search and replace
  46. '  LOGDOWN    59400   Records download in private directory
  47. '  MARKTIME   60200   Give visual feedback during lengthy process
  48. '  METAGSR    60130   Meta statement global search and replace
  49. '  MIMPORT    59698   Allow local user to import a text file to a message
  50. '  MUZAK      59100   Play musical themes for different RBBS functions
  51. '  NEWPASWRD  60668   Get a new password
  52. '  PERSFILE   59300   View and select personal files for downloading
  53. '  PROTOCOL   62600   Determine if external protocols are available
  54. '  PUTMATTR   62520   Save attributes of original message
  55. '  REMOVE     58210   Remove characters from within strings
  56. '  ROTORSDIR  58700   Searches for a file using list of subdirs
  57. '  RPTTIME    62540  Report date/time and time on
  58. '  SETABORT   58750   Set time for a process to abort
  59. '  SETECHO    59600   Set RBBS properly for who is to echo
  60. '  SETHILITE  59934   Set user preference on highlighting
  61. '  SETUGD     59980   Sets graphic preference for text file display
  62. '  SMARTTXT   58250   Process SMART TEXT control strings
  63. '  SUBMENU    59500   Processes options that have sub-menus
  64. '  TIMEDOUT   63000   Write timed exit semaphore file
  65. '  TIMELOCK   60150   Check for TIME LOCK on certain features
  66. '  TRANSFER   62624   RBBS-PC support for external protocols for file transfer
  67. '  TOGGLE     57000   Toggles or views user options
  68. ' TWOBYTEDATE 59200   Reduces a data to 2 byte string for space compression
  69. '  UNCDATE    59902   Uncompresses a 2 byte date
  70. '  USERCOLOR  59965   Lets user set color for text and whether bold
  71. '  USERFACE   59450   Processes programmable user interface
  72. '  VIEWARC    64600   Display .ARC file contents to user
  73. '  XFRETURN   62629   Private door exit routine
  74. '  WIPELINE   58800   Wipes away a line so next prints in its place
  75. '  WORDWRAP   59710  Adjust a message --wrap linesand perserve paragraphs
  76. '
  77. '  $INCLUDE: 'RBBS-VAR.BAS'
  78. '
  79. 57000 ' $SUBTITLE: 'TOGGLE - Toggle User Preferences'
  80. ' $PAGE
  81. '
  82. '  NAME    -- TOGGLE
  83. '
  84. '  INPUTS  -- TOGGLE.OPTION      Option to toggle or view
  85. '                                           according to the following:
  86. '    TOGGLE.OPTION         PREFERENCE
  87. '   TOGGLE   VIEW
  88. '     1       -1           Autodownload
  89. '     2       -2           Bulletin review on logon
  90. '     3       -3           Case change
  91. '     4       -4           File review on logon
  92. '     5       -5           Highlight
  93. '     6       -6           Line feeds
  94. '     7       -7           Nulls
  95. '     8       -8           TurboKey
  96. '     9       -9           Expert
  97. '    10      -10           Bell
  98. '
  99. '  OUTPUTS -- SUBROUTINE.PARAMETER   passed from TPUT
  100. '
  101. '  PURPOSE -- Sets or views any single user preference value
  102. '
  103.       SUB TOGGLE (TOGGLE.OPTION) STATIC
  104.       SUBROUTINE.PARAMETER = 0
  105.       IF TOGGLE.OPTION < 0 THEN _
  106.          GOTO 57005
  107.       ON TOGGLE.OPTION GOSUB _
  108.          57010, _         'Autodownload
  109.          57120, _         'Bulletin review on logon
  110.          57260, _         'Case change
  111.          57150, _         'File review on logon
  112.          57040, _         'Highlight
  113.          57100, _         'Line feeds
  114.          57210, _         'Nulls
  115.          57230, _         'TurboKey
  116.          57190, _         'Expert
  117.          57170            'Bell
  118.       EXIT SUB
  119. 57005 CALL ASKMORE ("",TRUE,TRUE,X,TRUE)
  120.       ON -TOGGLE.OPTION GOSUB _
  121.          57030, _         'Autodownload
  122.          57130, _         'Bulletin review on logon
  123.          57270, _         'Case change
  124.          57160, _         'File review on logon
  125.          57050, _         'Highlight
  126.          57110, _         'Line feeds
  127.          57220, _         'Nulls
  128.          57240, _         'TurboKey
  129.          57200, _         'Expert
  130.          57180            'Bell
  131.       EXIT SUB
  132. 57010 IF AUTODOWNLOAD.DESIRED THEN _
  133.          GOTO 57020
  134.       IF NOT AUTODOWNLOAD.VERIFIED THEN _
  135.          CALL TESTUSER
  136.       IF NOT AUTODOWNLOAD.AVAILABLE THEN _
  137.          CALL QTPUT1 ("Your comm pgm does not support AUTODOWNLOAD") : _
  138.          AUTODOWNLOAD.DESIRED = TRUE
  139. 57020 AUTODOWNLOAD.DESIRED = NOT AUTODOWNLOAD.DESIRED
  140. 57030 A$ = "Autodownload " + FNOFFON$(AUTODOWNLOAD.DESIRED)
  141.      CALL QTPUT1 (A$)
  142.      RETURN
  143. 57040 IF EMPHASIZE.ON.DEF$ = "" THEN _
  144.         CALL QTPUT1 ("Highlighting unavailable") : _
  145.         RETURN
  146.      CALL SETHILITE (NOT HIGHLIGHT.OFF)
  147.      IF HIGHLIGHT.OFF THEN _
  148.         CALL QTPUT (COLOR.RESET$,0)
  149.      GOSUB 57050
  150.      CALL USERCOLOR
  151.      RETURN
  152. 57050 IF EMPHASIZE.ON$ <> "" THEN _
  153.         EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
  154.         ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
  155.      CALL QTPUT1 (EMPHASIZE.ON$ + "Highlighting" + EMPHASIZE.OFF$ + _
  156.                  " " + FNOFFON$(NOT HIGHLIGHT.OFF))
  157.      RETURN
  158. 57100 LINE.FEEDS = NOT LINE.FEEDS
  159.       IF LOCAL.USER THEN _
  160.          LINE.FEEDS = TRUE
  161. 57110 CALL QTPUT1 ("Line Feeds " + FNOFFON$(LINE.FEEDS))
  162.       CALL SETCRLF
  163.       RETURN
  164. 57120 CHECK.BULLETIN.LOGON = NOT CHECK.BULLETIN.LOGON
  165. 57130 A$ = MID$("SKIP CHECK",1 -5 * CHECK.BULLETIN.LOGON,5) + _
  166.            " old BULLETINS in logon"
  167.       CALL QTPUT1 (A$)
  168.       RETURN
  169. 57150 SKIP.FILES.LOGON = NOT SKIP.FILES.LOGON
  170. 57160 A$ = MID$("CHECKSKIP",1 -5 * SKIP.FILES.LOGON,5) + _
  171.            " new files in logon"
  172.       CALL QTPUT1 (A$)
  173.       RETURN
  174. 57170 PROMPT.BELL = NOT PROMPT.BELL
  175. 57180 A$ = "Prompt Bell " + FNOFFON$(PROMPT.BELL)
  176.       CALL QTPUT1 (A$)
  177.       RETURN
  178. 57190 EXPERT.USER = NOT EXPERT.USER
  179.       CALL SETEXPERT
  180. 57200 A$ = MID$("NoviceExpert",1 -6 * EXPERT.USER,6)
  181.       CALL QTPUT1 (A$)
  182.       RETURN
  183. 57210 NULLS = NOT NULLS
  184.       NUL$ = MID$(STRING$(5,0),1, - 5 * NULLS)
  185.       CALL SETCRLF
  186. 57220 A$ = "Nulls " + FNOFFON$(NULLS)
  187.       CALL QTPUT1 (A$)
  188.       RETURN
  189. 57230 TURBO.KEY.USER = NOT TURBO.KEY.USER
  190. 57240 CALL QTPUT1 ("TurboKey " + FNOFFON$(TURBO.KEY.USER))
  191.       RETURN
  192. 57260 UPPER.CASE = NOT UPPER.CASE
  193. 57270 A$ = "UPPER CASE " + _
  194.             MID$("and lowerONLY",1 - 9 * UPPER.CASE,9)
  195.       CALL QTPUT1 (A$)
  196. 57280 USE.TPUT = (UPPER.CASE OR XON.XOFF)
  197.       RETURN
  198.       END SUB
  199. '
  200. 58190 ' $SUBTITLE: 'CHKNARY - subroutine to check for a string in an array'
  201. ' $PAGE
  202. '
  203. '  NAME    -- CHKNARY
  204. '
  205. '  INPUTS  -- PARAMETER                      MEANING
  206. '             ELEMENT$                THE STRING TO CHECK FOR
  207. '             ARRAY$()                THE ARRAY TO BE SEARCHED
  208. '             NUM.ENTRIES.TO.SEARCH   NUMBER OF ENTRIES WITHIN IN
  209. '                                                THE ARRAY TO BE SEARCHED
  210. '
  211. '  OUTPUTS -- IS.IN.ARA               0 = STRING NOT FOUND IN THE
  212. '                                         ARRAY SPECIFIED
  213. '                                     OTHERWISE IT IS THE NUMBER OF
  214. '                                     ELEMENT WITHIN THE ARRAY THAT
  215. '                                     WAS FOUND TO MATCH
  216. '
  217. '  PURPOSE -- Search an array for a specified string and, if found,
  218. '             return the number of the element that matched.
  219. '
  220.       SUB CHKNARY (ELEMENT$,ARRAY$(1),NUM.ENTRIES.TO.SEARCH,IS.IN.ARA) STATIC
  221.       IS.IN.ARA = 1
  222.       CALL ALLCAPS (ELEMENT$)
  223.       MAX.TRIES = NUM.ENTRIES.TO.SEARCH + 1
  224.       ARRAY$(MAX.TRIES) = ELEMENT$
  225.       WHILE ARRAY$(IS.IN.ARA) <> ELEMENT$
  226.          IS.IN.ARA = IS.IN.ARA + 1
  227.       WEND
  228.       IF IS.IN.ARA = MAX.TRIES THEN _
  229.          IS.IN.ARA = 0
  230.       END SUB
  231. 58200 ' $SUBTITLE: 'FMS - subroutine to search the upload management system'
  232. ' $PAGE
  233. '
  234. '  NAME    -- FMS
  235. '
  236. '  INPUTS  -- PARAMETER                      MEANING
  237. '             DIR.TO.SEARCH$          RBBS-PC "DIR" CATEGORY TO LOOK
  238. '                                     FOR
  239. '             SEARCH.STRING$          STRING TO SEARCH FOR
  240. '             SEARCH.DATE$            DATE TO SEARCH FOR
  241. '             CATEGORY.NAME$()
  242. '             CATEGORY.CODE$()
  243. '             CATEGORY.DESC$()
  244. '             CAT.FOUND
  245. '             NUM.CATEGORIES
  246. '
  247. '  OUTPUTS -- PROCESSED.IN.FMS
  248. '             DOWNLOAD.FLAG
  249. '
  250. '  PURPOSE -- To search the file management system and display the
  251. '             files being searched for as well as the catetory descriptions
  252. '
  253.       SUB FMS (DIR.TO.SEARCH$,SEARCH.STRING$,SEARCH.DATE$, _
  254.                PROCESSED.IN.FMS,CATEGORY.NAME$(1),CATEGORY.CODE$(1), _
  255.                CATEGORY.DESC$(1),DOWNLOAD.FLAG,CAT.FOUND,ABORT.INDEX) STATIC
  256. '      DOWNLOAD.FLAG = 0
  257. '      CALL CHKNARY (DIR.TO.SEARCH$,CATEGORY.NAME$(),NUM.CATEGORIES,CAT.FOUND)
  258. '      PROCESSED.IN.FMS = PROCESSED.IN.FMS OR (CAT.FOUND > 0)
  259. '      IF PROCESSED.IN.FMS THEN _
  260. '         SUBROUTINE.PARAMETER = 5 : _
  261. '         GOSUB 58202 : _
  262. '         A$ = "Scanning directory " + _
  263. '              DIR.TO.SEARCH$ + _
  264. '              HDR$ + _
  265. '              " - " + _
  266. '              CATEGORY.DESC$(CAT.FOUND) : _
  267. '         CALL TPUT : _
  268. '         CAT$ = CATEGORY.CODE$(CAT.FOUND) : _
  269. '         CALL DISUPDIR (CAT$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG,ABORT.INDEX)
  270. '      EXIT SUB
  271. '58202 A$ = SEARCH.DATE$
  272. '      IF LEN(A$) > 0 THEN _
  273. '         A$ = MID$(A$,3) + LEFT$(A$,2)
  274. '      HDR$ = " for " + _
  275. '             SEARCH.STRING$ + _
  276. '             A$
  277. '      IF LEN(HDR$) < 6 THEN _
  278. '         HDR$ = ""
  279. '      RETURN
  280. '      END SUB
  281. DOWNLOAD.FLAG = 0
  282.       CALL CHKNARY (DIR.TO.SEARCH$,CATEGORY.NAME$(),NUM.CATEGORIES,CAT.FOUND)
  283.       PROCESSED.IN.FMS = PROCESSED.IN.FMS OR (CAT.FOUND > 0)
  284.       IF FG.4$ <> "" THEN _
  285.      FG.5$ = ESCAPE$ + "[1;34;40m" : _
  286.      FG.6$ = ESCAPE$ + "[1;37;41m" : _
  287.      FG.7$ = ESCAPE$ + "[1;37;44m" : _
  288.      ELSE _
  289.      FG.5$ = "" : FG.6$ = "" : FG.7$ = ""
  290.      IF PROCESSED.IN.FMS THEN _
  291.      SUBROUTINE.PARAMETER = 5 : _
  292.      GOSUB 58202 : _
  293.      CALL QTPUT("",1) : _
  294.      CALL QTPUT(FG.5$+"╔═"+FG.6$+" "+DIR.TO.SEARCH$+" "+FG.5$+"═══",0) : _
  295.      CALL QTPUT(FG.6$ +" "+ CATEGORY.DESC$(CAT.FOUND) +" " + FG.5$ + "════" + _
  296.             FG.3$+" " + COLOR.RESET$+ HDR$,1) : _
  297.      CALL QTPUT(FG.5$+ "║",1)  : _
  298.      CALL QTPUT("╚═"+FG.7$+"File Name"+FG.5$+"═════" + FG.7$ + "Size" + _
  299.             FG.5$+"═════",0) : _
  300.      CALL QTPUT(FG.7$+"Date"+FG.5$+"════"+FG.7$ + "Description"+ _
  301.           FG.5$+"════════════════════════════"+FG.3$+" "+EMPHASIZE.OFF$,1) : _
  302.      CAT$ = CATEGORY.CODE$(CAT.FOUND) : _
  303.      CALL DISUPDIR (CAT$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG,ABORT.INDEX)
  304.       EXIT SUB
  305. 58202 A$ = SEARCH.DATE$
  306.       IF LEN(A$) > 0 THEN _
  307.      A$ = MID$(A$,3) + LEFT$(A$,2)
  308.       HDR$ = SEARCH.STRING$ + _
  309.          A$
  310.       IF HDR$ <> "" THEN _
  311.      HDR$ = FG.4$ + "Scanning for "  + FG.2$ + HDR$
  312.       RETURN
  313.       END SUB
  314. 58210 ' $SUBTITLE: 'REMOVE - subroutine to delete a string from within a string'
  315. ' $PAGE
  316. '
  317. '  NAME    -- REMOVE
  318. '
  319. '  INPUTS  -- PARAMETER                      MEANING
  320. '             BADSTRING$              STRING CONTAINING CHARACTERS
  321. '                                     TO BE DELETED FROM "L$"
  322. '             L$                      STRING TO BE ALTERED
  323. '
  324. '  OUTPUTS -- L$                      WITH THE CHARACTERS IN
  325. '                                     "BADSTRING#" DELETED FROM IT
  326. '
  327. '  PURPOSE -- To remove all instances of the characters in
  328. '                        "BADSTRING$" from "L$"
  329. '
  330.       SUB REMOVE (L$,BADSTRNG$) STATIC
  331.       J = 0
  332.       FOR I=1 TO LEN(L$)
  333.          IF INSTR(BADSTRNG$,MID$(L$,I,1)) = 0 THEN _
  334.             J = J + 1 : _
  335.             MID$(L$,J,1) = MID$(L$,I,1)
  336.       NEXT I
  337.       L$ = LEFT$(L$,J)
  338.       END SUB
  339. '
  340. 58250 ' $SUBTITLE: 'SMARTTXT - smart text substitution'
  341. ' $PAGE
  342. '
  343. '  NAME    -- SMARTTXT   (WRITTEN BY DOUG AZZARITO)
  344. '
  345. '  INPUTS  -- STRNG.WORK$        string to scan for Smart Text
  346. '             CR.FOUND           Does this line contain a CR?
  347. '             SMART.TEXT         Smart Text control code
  348. '
  349. '  OUTPUTS -- STRNG.WORK$        Input string with Smart replaced
  350. '
  351. '  PURPOSE -- Smart Text allows control strings in text files
  352. '             to be replaced at runtime with user info or other
  353. '             data.  The Smart Text control code is a 1-byte
  354. '             code (configurable) with a 2-byte action code.
  355. '
  356.       SUB SMARTTXT (STRNG.WORK$, CR.FOUND, OVERSTRIKE) STATIC
  357.       IF SMART.CARRY$<>"" THEN _
  358.          STRNG.WORK$ = SMART.CARRY$+STRNG.WORK$
  359.       INDEX = INSTR(STRNG.WORK$, SMART.TEXT$)
  360.       WHILE INDEX > 0 AND INDEX < LEN(STRNG.WORK$)-1
  361.          IF INSTR(MID$(STRNG.WORK$, INDEX+1,2)," ") THEN _
  362.             SMART.ACT = 0 _
  363.          ELSE _
  364.             SMART.ACT = INSTR(SMART.TABLE$, MID$(STRNG.WORK$, INDEX+1, 2))
  365.          IF SMART.ACT > 0 THEN _
  366.             SMART.ACT = (SMART.ACT+2)/3 : _
  367.             ON SMART.ACT GOSUB 58260, 58261, 58262, 58263, 58264, 58265, _
  368.                          58266, 58267, 58268, 58269, 58270, _
  369.                          58271, 58272, 58273, 58274, 58275, _
  370.                          58276, 58277, 58278, 58279, 58280, _
  371.                          58281, 58282, 58283, 58284, 58285 : _
  372.             IF OVERSTRIKE THEN _
  373.                MID$(STRNG.WORK$,INDEX) = SMART.HOLD$ _
  374.             ELSE STRNG.WORK$ = LEFT$(STRNG.WORK$, INDEX-1) + SMART.HOLD$ + _
  375.                                MID$(STRNG.WORK$,INDEX+3)
  376.          INDEX = INSTR(INDEX+1, STRNG.WORK$, CHR$(SMART.TEXT))
  377.       WEND
  378.       IF INDEX AND (INDEX > LEN(STRNG.WORK$)-2) AND NOT CR.FOUND THEN _
  379.          SMART.CARRY$ = MID$(STRNG.WORK$,INDEX) : _
  380.          STRNG.WORK$ = LEFT$(STRNG.WORK$,INDEX-1) : _
  381.       ELSE _
  382.          SMART.CARRY$ = ""
  383.       EXIT SUB
  384. 58258 LAST.SMART.COLOR$ = SMART.HOLD$                                ' MZ060302
  385.       RETURN                                                         ' MZ060302
  386. 58260 LINES.PRINTED = 0                     ' CS (Clear screen line count reset)
  387.       SMART.HOLD$ = ""
  388.       RETURN
  389. 58261 LINES.PRINTED = PAGE.LENGTH           ' PB Page Break
  390.       IF NON.STOP THEN _                    ' force a 1-time pause
  391.          ONE.STOP = TRUE : _                ' if NON STOP is on
  392.          NON.STOP = FALSE
  393.       SMART.HOLD$ = ""
  394.       FORCE.KEYBOARD = TRUE
  395.       RETURN
  396. 58262 NON.STOP = TRUE                       ' NS Non-stop
  397.       SMART.HOLD$ = ""
  398.       RETURN
  399. 58263 IF GLOBAL.SYSOP THEN _       'FN First Name
  400.          SMART.HOLD$ = ORIG.SYSOP.FN$ _
  401.       ELSE SMART.HOLD$ = FIRST.NAME$
  402.       RETURN
  403. 58264 IF GLOBAL.SYSOP THEN _
  404.          SMART.HOLD$ = ORIG.SYSOP.LN$ _
  405.       ELSE SMART.HOLD$ = LAST.NAME$
  406.       RETURN
  407. 58265 SMART.HOLD$ = MID$(STR$(USER.SECURITY.LEVEL),2)   ' SL Security level
  408.       RETURN
  409. 58266 SMART.HOLD$ = DATE$
  410.       RETURN
  411. 58267 CALL AMORPM                                                    ' KG061203
  412.       SMART.HOLD$ = TIM$
  413.       RETURN
  414. 58268 CALL TIMEREMAIN(TIME.REMAINING!)      ' TR Time remaining (in mins)
  415.       SMART.HOLD$ = MID$(STR$(INT(TIME.REMAINING!)),2)
  416.       RETURN
  417. 58269 CALL TIMEREMAIN(TIME.REMAINING!)      ' TE Time elapsed (mm:ss)
  418.       SMART.HOLD$ = MID$(STR$(INT(TCA!/60)),2)+":"+ MID$(STR$((TCA! MOD 60)+100),3)
  419.       RETURN
  420. 58270 SMART.HOLD$ = MID$(STR$(INT((TIME.LOCK.SET+0.5)/60)),2) ' TL - Time Lock period
  421.       SMART.HOLD$ = SMART.HOLD$ + ":"+ MID$(STR$((TIME.LOCK.SET MOD 60)+100),3)
  422.       RETURN
  423. 58271 SMART.HOLD$ = MID$(STR$(DAYS.IN.REGISTRATION.PERIOD),2)
  424.       RETURN                                ' RP Registration Length
  425. 58272 SMART.HOLD$ = MID$(STR$(REG.DAYS.REMAINING),2)
  426.       RETURN                                ' RR Registration Remaining
  427. 58273 SMART.HOLD$ = CITY.STATE$             ' CT Users CITY & STATE
  428.       RETURN
  429. 58274 SMART.HOLD$ = FG.1$                   ' C1 Color 1
  430.       GOTO 58258                                                     ' MZ060302
  431. 58275 SMART.HOLD$ = FG.2$                   ' C2 Color 2
  432.       GOTO 58258                                                     ' MZ060302
  433. 58276 SMART.HOLD$ = FG.3$                   ' C3 Color 3
  434.       GOTO 58258                                                     ' MZ060302
  435. 58277 SMART.HOLD$ = FG.4$                   ' C4 Color 4
  436.       GOTO 58258                                                     ' MZ060302
  437. 58278 SMART.HOLD$ = EMPHASIZE.OFF$          ' C0 Reset color
  438.       LAST.SMART.COLOR$ = ""                                         ' MZ060302
  439.       RETURN
  440. 58279 SMART.HOLD$ = MID$(STR$(INT(DL.TODAY!)),2)
  441.       RETURN                                ' DD files Dnlded TODAY
  442. 58280 SMART.HOLD$ = MID$(STR$(INT(BYTES.TODAY!)),2)
  443.       RETURN                                ' BD Bytes Dnlded TODAY
  444. 58281 SMART.HOLD$ = MID$(STR$(INT(DLBYTES!)),2)
  445.       RETURN                                ' DB Download Bytes
  446. 58282 SMART.HOLD$ = MID$(STR$(INT(ULBYTES!)),2)
  447.       RETURN                                ' UB Upload Bytes
  448. 58283 SMART.HOLD$ = MID$(STR$(DOWNLOADS),2) ' DL Number of Dnlds
  449.       RETURN
  450. 58284 SMART.HOLD$ = MID$(STR$(UPLOADS),2)   ' UL Number of Uplds
  451.       RETURN
  452. 58285 SMART.HOLD$ = FILE.NAME$              ' FILE NAME
  453.       END SUB
  454. '
  455. 58300 ' $SUBTITLE: 'BUFSTRNG - write a string with imbedded CR/LF'
  456. ' $PAGE
  457. '
  458. '  NAME    -- BUFSTRNG
  459. '
  460. '  INPUTS  -- PARAMETER                      MEANING
  461. '             STRNG$                  STRING TO BE WRITTEN OUT
  462. '             DATA.SIZE               LENGTH OF STRING - # LEFT
  463. '                                        CHARS TO OUTPUT
  464. '
  465. '  OUTPUTS -- STRNG$                  IS WRITTEN TO THE USER
  466. '
  467. '  PURPOSE -- To search the string, STRNG$, for embedded carriage
  468. '             returns and line feeds and write out each line with
  469. '             the appropriate substitution (cr/lf if to the local
  470. '             screen or cr/nulls/lf if to the communications port).
  471. '
  472.       SUB BUFSTRNG (STRNG$,PASSED.DATA.SIZE,ABORT.INDEX) STATIC
  473.       L = LEN(STRNG$)
  474.       IF PASSED.DATA.SIZE < L THEN _
  475.          L = PASSED.DATA.SIZE
  476.       IF L < 1 THEN _
  477.          EXIT SUB
  478.       FF = PAGE.LENGTH - 1
  479.       START.BYTE = 1
  480.       IF CARRY.OVER THEN _
  481.          IF ASC(STRNG$) = 10 THEN _
  482.             START.BYTE = 2 : _
  483.             CALL SKIPLINE (1)
  484.       CARRY.OVER = (MID$(STRNG$,L,1) = CARRIAGE.RETURN$)
  485.       L = L + CARRY.OVER
  486. 58301 CRAT = INSTR(START.BYTE,STRNG$,CARRIAGE.RETURN$)
  487.       IF CRAT > 0 AND CRAT < L THEN _
  488.          CR.FOUND = (MID$(STRNG$,CRAT + 1,1) = LINE.FEED$) _
  489.       ELSE CR.FOUND = FALSE
  490.       EOL.LEN = -2 * CR.FOUND
  491.       IF CR.FOUND THEN _
  492.          EOD = CRAT _
  493.       ELSE EOD = L + 1
  494.       NUM.BYTES = EOD - START.BYTE
  495.       STRNG.WORK$ = MID$(STRNG$,START.BYTE,NUM.BYTES)
  496.       IF NOT DELETE.INVALID THEN _
  497.          GOTO 58304
  498.       INDEX = INSTR(STRNG.WORK$,"[")
  499.       J = LEN(STRNG.WORK$) - 1
  500.       WHILE INDEX > 0 AND INDEX < J
  501.          IF MID$(STRNG.WORK$,INDEX + 2,1) = "]" THEN _
  502.             IF INSTR (INVALID.OPTS$,MID$(STRNG.WORK$,INDEX + 1,1)) THEN _
  503.                MID$(STRNG.WORK$,INDEX + 1,1) = "*"
  504.          INDEX = INSTR(INDEX + 1,STRNG.WORK$,"[")
  505.       WEND
  506. 58304 IF SMART.TEXT THEN _
  507.          CALL SMARTTXT (STRNG.WORK$, CR.FOUND, FALSE)
  508.       CALL QTPUT (STRNG.WORK$, - (CR.FOUND))
  509.       IF RET THEN _
  510.          EXIT SUB
  511.       IF LINES.PRINTED < FF THEN _
  512.          GOTO 58305
  513.       CALL CHKTREMAIN (TIME.REMAINING!)
  514.       CALL CHKCARRIER                                                ' KG061203
  515.       IF SUBROUTINE.PARAMETER = -1 THEN _
  516.          EXIT SUB
  517.       IF NON.STOP THEN _
  518.          GOTO 58305
  519.       IF NOT CR.FOUND THEN _                                         ' KG052002
  520.          GOTO 58305                                                  ' KG052002
  521.       CALL ASKMORE ("",TRUE,FALSE,ABORT.INDEX,STOP.INTERRUPTS)
  522.       IF NO THEN _
  523.          RET = TRUE : _
  524.          EXIT SUB
  525. 58305 START.BYTE = EOD + EOL.LEN
  526.       IF START.BYTE <= L THEN _
  527.          GOTO 58301
  528.       END SUB
  529. 58400 ' $SUBTITLE: 'BUFFILE - subroutine to write a sequential file to the user'
  530. ' $PAGE
  531. '
  532. '  NAME    -- BUFFILE
  533. '
  534. '  INPUTS  -- PARAMETER                      MEANING
  535. '             FILENAME$               NAME OF THE FILE TO WRITE TO
  536. '                                                OUT TO THE USER
  537. '
  538. '  OUTPUTS -- NONE                    FILE IS WRITTEN TO THE USER
  539. '
  540. '  PURPOSE -- To display a sequential file to the user
  541. '
  542.       SUB BUFFILE (FILNAME$,ABORT.INDEX) STATIC
  543.       CALL FINDIT (FILNAME$)
  544.       IF NOT OK THEN _
  545.          EXIT SUB
  546.       NO = FALSE
  547.       CALL OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC,BUFFER.SIZE)
  548.       DATA.SIZE = BUFFER.SIZE
  549.       FIELD 2, DATA.SIZE AS SEQ.REC$
  550.       NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
  551.       IF NOT STOP.INTERRUPTS THEN _
  552.          IF NOT CONCAT.FILES THEN _
  553.             IF NOT NON.STOP THEN _
  554.                A$ = "* Ctrl-K(^K) / ^X aborts. ^S suspends ^Q resumes *" : _
  555.                SUBROUTINE.PARAMETER = 2 : _
  556.                CALL TPUT
  557.       TU = 0
  558. 58405 TU = TU + 1
  559.       IF TU < NUM.RECS THEN _
  560.          GET 2,TU _
  561.       ELSE IF TU = NUM.RECS THEN _
  562.               GET 2,TU : _
  563.               X = INSTR(SEQ.REC$,CHR$(26)) : _
  564.               IF X = 0 OR X > LEN.LAST.REC THEN _
  565.                  DATA.SIZE = LEN.LAST.REC _
  566.               ELSE DATA.SIZE = X - 1 _
  567.            ELSE GOTO 58419
  568.       IF LOCAL.USER THEN _
  569.          GOTO 58406
  570.       CALL EOFCOMM (CHAR%)
  571.       IF CHAR% <> -1 THEN _
  572.          GOTO 58407            ' comm port input
  573. 58406 KEYBOARD.STACK$ = INKEY$
  574.       IF KEYBOARD.STACK$ = "" THEN _  ' no keyboard input
  575.          CALL BUFSTRNG (SEQ.REC$,DATA.SIZE,ABORT.INDEX) : _
  576.          GOTO 58408
  577. 58407 A$ = LEFT$(SEQ.REC$,DATA.SIZE)  ' process comm/keyboard
  578.       SUBROUTINE.PARAMETER = 4
  579.       CALL TPUT
  580. 58408 IF SUBROUTINE.PARAMETER <> -1 AND NOT RET THEN _
  581.          GOTO 58405
  582. 58419 CLOSE 2
  583.       BYPASS.TIME.CHECK = FALSE
  584.       STOP.INTERRUPTS = FALSE
  585.       CALL QTPUT (EMPHASIZE.OFF$,0)
  586.       END SUB
  587. 58600 ' $SUBTITLE: 'FINDLAST - find last occurence of a string'
  588. ' $PAGE
  589. '
  590. '  NAME    -- FINDLAST
  591. '
  592. '  INPUTS  -- PARAMETER             MEANING
  593. '                        LOOK.IN$           STRING TO LOOK INTO
  594. '                        LOOK.FOR$          STRING TO SEARCH FOR
  595. '
  596. '  OUTPUTS -- WHERE.FOUND        POSITION IN LOOK.IN$ THAT
  597. '                                   LOOK.FOR$ FOUND
  598. '             NUM.FINDS          HOW MANY OCCURENCES IN LOOK.IN$
  599. '
  600. '  PURPOSE -- Finds last occurence of LOOK.FOR$ in LOOK.IN$ and
  601. '             returns count of # of occurences.  If none found,
  602. '             both returned parameters are set to 0.
  603. '
  604.       SUB FINDLAST (LOOK.IN$,LOOK.FOR$,WHERE.FOUND,NUM.FINDS) STATIC
  605.       WHERE.FOUND = INSTR(LOOK.IN$,LOOK.FOR$)
  606.       NUM.FINDS = -(WHERE.FOUND > 0)
  607.       NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
  608.       WHILE NEXT.FOUND > 0
  609.          NUM.FINDS = NUM.FINDS + 1
  610.          WHERE.FOUND = NEXT.FOUND
  611.          NEXT.FOUND = INSTR(WHERE.FOUND + 1,LOOK.IN$,LOOK.FOR$)
  612.       WEND
  613.       END SUB
  614. 58700 ' $SUBTITLE: 'ROTORSDIR - search thru a list of subdirs for a file'
  615. ' $PAGE
  616. '
  617. '  NAME    -- ROTORSDIR
  618. '
  619. '  INPUTS  --     PARAMETER                    MEANING
  620. '             FILNAME$                  FILE NAME TO LOOK FOR
  621. '             SDIR.ARA                  ARRAY OF SUBDIRECTORIES
  622. '             MAX.SEARCH                MAX # OF SUBDIRECTORIES
  623. '             MARK.TIME                 WHETHER TO MARK TIME
  624. '
  625. '  OUTPUTS -- FNAME$                    ADD SUBDIRECTORY TO THE
  626. '                                       FILE NAME IF FOUND.  OTHER-
  627. '                                       WISE DON'T.
  628. '             OK                        TRUE IF FILE WAS FOUND
  629. '
  630. '  PURPOSE -- Hunt through a list of subdirectories to determine
  631. '             if a file is in any of them.  If file is found, open
  632. '             the file as file #2, add the drive/path to the file
  633. '             name, and sets OK to true.  If file isn't found, set
  634. '             file name to the last subdirectory searched -- which
  635. '             should be the upload subdirectory.
  636. '
  637. '             If the library menu is selected (MENU.INDEX = 6), then
  638. '             only 2 subdirectories are searched. The first being
  639. '             the work disk and the second being the selected
  640. '             library disk.
  641. '
  642.       SUB ROTORSDIR (FILNAME$,SDIR.ARA$(1),MAX.SEARCH,MARK.TIME) STATIC
  643.       OK = FALSE
  644.       IF MARK.TIME THEN _
  645.          CALL QTPUT ("Searching for "+FILNAME$,0)
  646.       IF MENU.INDEX = 6 THEN _
  647.          GOTO 58705
  648.       NUM.SEARCH = 1
  649.       X = 0
  650.       WHILE (NOT OK) AND NUM.SEARCH <= MAX.SEARCH AND _
  651.          SDIR.ARA$(NUM.SEARCH) <> ""
  652.          IF MARK.TIME THEN _
  653.             CALL MARKTIME (X)
  654.          X$ = SDIR.ARA$(NUM.SEARCH) + _
  655.               FILNAME$
  656.          CALL FINDIT (X$)
  657.          NUM.SEARCH = NUM.SEARCH + 1
  658.       WEND
  659.       GOTO 58710
  660. 58705 X$ = LIBRARY.WORK.DISK.PATH$ + _
  661.            FILNAME$
  662.       CALL FINDIT (X$)
  663.       IF OK THEN _
  664.          GOTO 58710
  665.       X$ = LIBRARY.DRIVE$ + _
  666.            FILNAME$
  667.       CALL FINDIT (X$)
  668. 58710 FILNAME$ = X$
  669.       CALL SKIPLINE (-MARK.TIME)
  670.       END SUB
  671. 58800 ' $SUBTITLE: 'WIPELINE - Wipe away a line so next overprints'
  672. ' $PAGE
  673. '
  674. '  NAME    -- WIPELINE
  675. '
  676. '  INPUTS  --     PARAMETER                    MEANING
  677. '                 CARRIAGE.RETURN$
  678. '                 CHARS.TO.WIPE            # OF CHARACTERS TO BLANK
  679. '                 NULLS
  680. '
  681. '  OUTPUTS -- NONE
  682. '
  683. '  PURPOSE -- Wipe away a line and leave cursor at beginning of the
  684. '             same line so that the next line will print in its place
  685. '
  686.       SUB WIPELINE (CHARS.TO.WIPE) STATIC
  687.       IF NULLS OR CHARS.TO.WIPE > 79 THEN _
  688.          CALL SKIPLINE (1) : _
  689.          EXIT SUB
  690.       IF NOT LOCAL.USER THEN _
  691.          STRNG$ = CARRIAGE.RETURN$ + SPACE$(CHARS.TO.WIPE) + CARRIAGE.RETURN$ : _
  692.          IF FOSSIL THEN _
  693.             BYTES% = LEN(STRNG$) : _
  694.             CALL FOSWRITE(COMPORT%,BYTES%,STRNG$) _
  695.          ELSE PRINT #3,STRNG$
  696.       IF SNOOP THEN _
  697.          LOCATE ,1 :  _
  698.          CALL LPRNT(SPACE$(CHARS.TO.WIPE),0) : _
  699.          LOCATE ,1
  700.       IF F7.MESSAGE$ = "" OR _
  701.          F7.MESSAGE$ = "NONE" OR _
  702.          NOT SYSOP.NEXT THEN _
  703.          EXIT SUB
  704.       BYPASS.TIME.CHECK = TRUE
  705.       CALL BUFFILE (F7.MESSAGE$,X)
  706.       END SUB
  707. 58895 ' $SUBTITLE: 'GETDIRS -- Prompt for directories to search'
  708. ' $PAGE
  709. '
  710. '  NAME    -- GETDIRS
  711. '
  712. '  INPUTS  --     PARAMETER                    MEANING
  713. '                 DIR.PROMPT$             BASE OF DIRECTORY PROMPT
  714. '                 SHOW.HELP               Whether to display help
  715. '                                            on entry
  716. '  OUTPUTS --     B$
  717. '                 Q
  718. '
  719. '  PURPOSE -- Prompt for directories to search
  720. '
  721.       SUB GETDIRS (SHOW.HELP) STATIC
  722.       IF SHOW.HELP AND (ANS.INDEX <= LAST.INDEX ) THEN _             ' KG090205
  723.          GOTO 58902
  724. 58900 A$ = DIR.PROMPT$
  725.       MACRO.MIN = 2
  726.       CALL POPCSTACK                                                 ' KG081201
  727.       IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
  728.          EXIT SUB
  729.       CALL ALLCAPS (B$(ANS.INDEX))                                   ' KG081201
  730.       IF B$(ANS.INDEX) = "Q" THEN _                                  ' KG081201
  731.          Q = 0 : _
  732.          EXIT SUB
  733.       A = INSTR("E+.E-.E.L.H.?.",B$(ANS.INDEX)+".")                  ' KG081201
  734.       IF A = 0 THEN _
  735.          EXIT SUB
  736.       IF A > 8 THEN _
  737.          GOTO 58901
  738.       IF A = 7 THEN _
  739.          EXTENDED.OFF = NOT EXTENDED.OFF _
  740.       ELSE EXTENDED.OFF = (A > 3)
  741.       CALL QTPUT1 ("Extended directory display "+MID$("ON OFF",1-3*EXTENDED.OFF,3))
  742.       GOTO 58900
  743. 58901 IF A = 9 AND LAST.INDEX > 1 THEN _                             ' KG090205
  744.          LAST.INDEX = LAST.INDEX - 1 : _                             ' KG090205
  745.          ANS.INDEX = ANS.INDEX - 1 : _                               ' KG090205
  746.          FOR B = ANS.INDEX TO LAST.INDEX : _                         ' KG090205
  747.             B$(B) = B$(B + 1) : _
  748.          NEXT : _
  749.          EXIT SUB
  750. 58902 FILE.NAME$ = DIRECTORY.PATH$ + DIRECTORY.PREFIX$ + _
  751.                     "." + DIRECTORY.EXTENTION$
  752.       GDEFAULT$ = MID$(" GC",GR + 1, 1)
  753.       CALL GRAPHIC (GDEFAULT$,FILE.NAME$)
  754.       CALL BUFFILE (FILE.NAME$,ANS.INDEX)                            ' KG081201
  755.       GOTO 58900
  756.       END SUB
  757. '
  758. 58950 ' $SUBTITLE: 'CONVDIRS -- Converts coded response to right directory'
  759. ' $PAGE
  760. '
  761. '  NAME    -- CONVDIRS
  762. '
  763. '  INPUTS  --     PARAMETER                    MEANING
  764. '                 STRT               ELEMENT TO BEGIN WITH
  765. '                 B$                 ARRAY TO CONVERT
  766. '                 Q                  LAST ELEMENT TO CONVERT
  767. '
  768. '  OUTPUTS --     B$                 CONVERTED DIRECTORY LIST
  769. '
  770. '  PURPOSE -- Let the user put in a short standard string for a directory
  771. '
  772. '
  773.       SUB CONVDIRS (STRT) STATIC
  774.       FOR I=STRT TO LAST.INDEX                                       ' KG081201
  775.          CALL ALLCAPS (B$(I))
  776.          IF B$(I)="U" THEN _
  777.             B$(I) = UPLOAD.DIR.CHECK$
  778.          IF B$(I) = "A" THEN _
  779.             B$(I) = "ALL"
  780.       NEXT
  781.       END SUB
  782. 59100 ' $SUBTITLE: 'MUZAK - subroutine to PLAY MUSIC'
  783. ' $PAGE
  784. '
  785. '  NAME    -- MUZAK
  786. '
  787. '  INPUTS  --   PARAMETER     MEANING
  788. '                       1   PLAY CONSIDER YOURSELF(OPENING SCREEN)
  789. '                       2   PLAY WALK RIGHT IN(NEW USERS)
  790. '                       3   PLAY DRAGNET (SECURITY VIOLATION)
  791. '                       4   PLAY GOODBYE CHARLIE (GOODBYE)
  792. '                       5   PLAY TAPS (ACCESS DENIED)
  793. '                       6   PLAY OOM PAH PAH (DOWNLOAD)
  794. '                       7   PLAY THNKS FOR MEMORIES(UPLOAD)
  795. '
  796. '  OUTPUTS -- NONE
  797. '
  798. '  PURPOSE -- Provide sysops and the visually impaired with
  799. '             auditory feedback on what RBBS-PC is doing
  800. '
  801.       SUB MUZAK (PASSED.ARG) STATIC
  802.       FF = PASSED.ARG
  803.       SUBROUTINE.PARAMETER = 0
  804.       IF (NOT SNOOP) OR (NOT MUSIC) OR LOCAL.USER.MODE THEN _
  805.          EXIT SUB
  806.       ON FF GOTO 59102,59104,59106,59108,59110,59112,59114
  807.       EXIT SUB
  808. 59102 '---[Introduction CONSIDER YOURSELF]---
  809.     LEC$ = "MBT180A4B-8B-8B-8B-2.G4A8F2"
  810.     PLAY "O2 X" + VARPTR$(LEC$)
  811.     EXIT SUB
  812. 59104 '---[New User WALK RIGHT IN]---
  813.     LEC1$ = "MBT180G4G4D2G8F+8F8E2A8B8"
  814.     LEC2$ = "C8C+8D8C8"
  815.     LEC3$ = "B4G2"
  816.     PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$)
  817.     EXIT SUB
  818. 59106 '---[Security Violation DRAGNET THEME]---
  819.      LEC$ = "MBT120C2D8E-4C2.C2D8E-4C4G-2."
  820.      PLAY "O2 X" + VARPTR$(LEC$)
  821.      EXIT SUB
  822. 59108 '---[Goodbye GOODBYE CHARLIE]---
  823.       LEC$ = "MBT180B-2.G2.F4D2."
  824.       PLAY "O2 X" + VARPTR$(LEC$)
  825.       EXIT SUB
  826. 59110 '---[Access Denied TAPS]---
  827.       LEC1$ = "MBT90F8A16"
  828.       LEC2$ = "C4."
  829.       LEC3$ = "A4F4C2.C8C16F2"
  830.       PLAY "O2 X" + VARPTR$(LEC1$) + "O3 X" + VARPTR$(LEC2$) + "O2 X" + VARPTR$(LEC3$)
  831.       EXIT SUB
  832. 59112 '---[Download OOM PAH PAH]---
  833.        LEC$ = "MBT180F4A4A4C4A4A4G4A4G4D2"
  834.        PLAY "O2 X" + VARPTR$(LEC$)
  835.        EXIT SUB
  836. 59114 '---[Upload THANKS FOR THE MEMORIES]---
  837.        LEC1$ = "MBT180C2."
  838.        LEC2$ = "A8G8F4D2"
  839.        PLAY "O3 X" + VARPTR$(LEC1$) + "O2 X" + VARPTR$(LEC2$)
  840.        END SUB
  841. 59200 ' $SUBTITLE: 'TWOBYTEDATE -- subroutine to put date in 2 bytes'
  842. ' $PAGE
  843. '
  844. '  NAME    -- TWOBYTEDATE
  845. '
  846. '  INPUTS  --   PARAMETER     MEANING
  847. '                  YY       FOUR DIGIT YEAR (I.E. 1987)
  848. '                  MM       MONTH
  849. '                  DD       DAY
  850. '                RESULT$    LOCATION TO PLACE THE RESULT
  851. '
  852. '  OUTPUTS -- RESULT$       TWO BYTE COMPRESSED DATE FOR USE IN
  853. '                           A RANDOM RECORD
  854. '
  855. '  PURPOSE -- Compress a Y,M,D date into two characters
  856. '
  857.       SUB TWOBYTEDATE (YY,MM,DD,RESULT$) STATIC
  858.       RESULT$ = CHR$(((YY - 1980) * 2) OR - ((MM AND 8) <> 0)) + _
  859.                 CHR$((MM AND NOT 8) * 32 + DD)
  860.       END SUB
  861. 59201 ' $SUBTITLE: 'CSTRDATE -- subroutine to Compress STRing DATE'
  862. ' $PAGE
  863. '
  864. '  NAME    -- CSTRDATE
  865. '
  866. '  INPUTS  --   PARAMETER     MEANING
  867. '                 STRNG$    String Date (mm-dd-yyyy)
  868. '
  869. '  OUTPUTS --    RESULT$    TWO BYTE COMPRESSED DATE FOR USE IN
  870. '                                      A RANDOM RECORD
  871. '
  872. '  PURPOSE -- Compress an 8-character date into two characters
  873. '
  874.       SUB CSTRDATE (STRNG$,RESULT$) STATIC
  875.       IF LEN(STRNG$) < 8 THEN _
  876.          EXIT SUB
  877.       YY = VAL(MID$(STRNG$,7))
  878.       MM = VAL(STRNG$)
  879.       DD = VAL(MID$(STRNG$,4))
  880.       CALL TWOBYTEDATE (YY,MM,DD,RESULT$)
  881.       END SUB
  882. 59202 ' $SUBTITLE: 'UNCDATE -- subroutine to UNCompress DATE'
  883. ' $PAGE
  884. '
  885. '  NAME    -- UNCDATE
  886. '
  887. '  INPUTS  --   PARAMETER      MEANING
  888. '             COMPRESSED.DATE$ Date in 2 byte compressed form
  889. '
  890. '  OUTPUTS --     YY           Year of compressed date
  891. '                 MM           Month of compressed date
  892. '                 DD           Day of compressed date
  893. '             DISPLAY.DATE$    8 char display date (mm-dd-yyyy)
  894. '
  895. '  PURPOSE -- Uncompress a 2 char date to get Y,M,D & display
  896. '
  897.       SUB UNCDATE (COMPRESSED.DATE$,YY,MM,DD,DISPLAY.DATE$) STATIC
  898.       CALL GETYMD (COMPRESSED.DATE$,1,YY)
  899.       CALL GETYMD (COMPRESSED.DATE$,2,MM)
  900.       CALL GETYMD (COMPRESSED.DATE$,3,DD)
  901.       DISPLAY.DATE$ = RIGHT$("00" + MID$(STR$(MM),2),2) + _
  902.                       "-" + _
  903.                       RIGHT$("00" + MID$(STR$(DD),2),2) + _
  904.                       "-" + _
  905.                       RIGHT$(STR$(YY),2)
  906.       END SUB
  907. 59204 ' $SUBTITLE: 'GETYMD -- subroutine to unpack a two-byte date'
  908. ' $PAGE
  909. '
  910. '  NAME    -- GETYMD
  911. '
  912. '  INPUTS  --   PARAMETER     MEANING
  913. '                 TWOBYTE$    PACKED TWO-BYTE DATE FIELD
  914. '                   YMD       1 = YEAR
  915. '                             2 = MONTH
  916. '                             3 = DAY
  917. '                 RESULT      LOCATION TO PLACE THE RESULT
  918. '
  919. '  OUTPUTS -- RESULT        FOUR DIGIT RESULT OF UNPAKING THE DATE
  920. '
  921. '  PURPOSE -- Unpack a compressed two-byte date field
  922. '
  923.       SUB GETYMD (TWOBYTE$,YMD,RESULT) STATIC
  924.       ON YMD GOTO 59206,59210,59215
  925.       EXIT SUB
  926. 59206 RESULT = (ASC(TWOBYTE$)AND NOT 1) / 2 + 1980
  927.       EXIT SUB
  928. 59210 RESULT = FIX((ASC(MID$(TWOBYTE$,2)) / 32)) OR ((ASC(TWOBYTE$) AND 1) * 8)
  929.       EXIT SUB
  930. 59215 RESULT = ASC(MID$(TWOBYTE$,2)) AND NOT 224
  931.       END SUB
  932. 59300 ' $SUBTITLE: 'PERSFILE - processes requests for personal files'
  933. ' $PAGE
  934. '
  935. '  NAME    -- PERSFILE
  936. '
  937. '  INPUTS  --     PARAMETER           MEANING
  938. '                            PERSONAL.CAT$     CATEGORY IN DIR FOR CALLER
  939. '                            PERSONAL.LEN      # CHARS IN PERSONAL CATEGORY
  940. '  OUTPUTS -- NONE UP DOWNLOADS
  941. '
  942. '  PURPOSE -- Show caller what personal files have for downloading,
  943. '             verify and process requests for downloads
  944. '
  945.       SUB PERSFILE (PERSONAL.CAT$,DOWNLOAD.FLAG) STATIC
  946.       CALL FINDIT (PERSONAL.DIR$)
  947. 59302 IF NOT OK THEN _
  948.          CALL QTPUT1 ("No personal files available") : _
  949.          LAST.INDEX = 0 : _                                          ' DA083001 
  950.          EXIT SUB
  951.       L = 36 + MAX.DESC.LEN + PERSONAL.LEN
  952.       IF LOF(2) < L THEN _
  953.         OK = FALSE : _
  954.         GOTO 59302
  955.       B$(0) = ""
  956.       CLOSE 2
  957.       IF SHARE.IT THEN _
  958.          OPEN PERSONAL.DIR$ FOR RANDOM SHARED AS #2 LEN=L _
  959.       ELSE OPEN "R",2,PERSONAL.DIR$,L
  960.       FIELD #2,33 + MAX.DESC.LEN AS PART.TO.PRINT$, _
  961.                PERSONAL.LEN    AS PRIVATE.CAT$, _
  962.                1               AS PERSONAL.STATUS$, _
  963.                2               AS FILLER$
  964.       MAX.PRINT = PAGE.LENGTH - 1
  965.       NON.STOP = NON.STOP OR (PAGE.LENGTH < 1)
  966.       LAST.REC = LOF(2) / L
  967.       IF DOWNLOADING THEN _
  968.          DOWNLOADING = FALSE : _
  969.          PERS.INDEX = DOWNLOAD.FLAG : _
  970.          DOWNLOAD.FLAG = 0 : _
  971.          GOTO 59306                                                  ' KG082601
  972. 59303 A$ = "Download what: L)ist, * = new, or file(s)" + _
  973.            PRESS.ENTER.EXPERT$                                       ' KG082601
  974.       MACRO.MIN = 99
  975.       CALL POPCSTACK                                                 ' KG082601
  976.       IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
  977.          EXIT SUB
  978. 59304 SELECTED.PROTOCOL$ = ""
  979.       IF LAST.INDEX > 1 THEN _                                       ' KG082601
  980.          IF LEN(B$(LAST.INDEX)) = 1 THEN _                           ' KG082601
  981.             SELECTED.PROTOCOL$ = B$(LAST.INDEX) : _                  ' KG082601
  982.             LAST.INDEX = LAST.INDEX - 1                              ' KG082601
  983.       IF LEN(B$(ANS.INDEX)) > 2 THEN _                               ' KG082601
  984.          GOTO 59330
  985.       CALL ALLCAPS (B$(ANS.INDEX))                                   ' KG082601
  986.       ON INSTR("L*",B$(ANS.INDEX)) GOTO 59305,59327                  ' KG082601
  987.       GOTO 59303
  988. 59305 PERS.INDEX = LAST.REC
  989.       L = FALSE
  990. 59306 IF PERS.INDEX < 1 THEN _
  991.          IF L THEN _
  992.             GOTO 59303 _
  993.          ELSE _
  994.             A$ = "No files for you" : _
  995.                  CALL QTPUT1 (A$) : _
  996.               GOTO 59303
  997.       GET #2,PERS.INDEX
  998.       PERS.INDEX = PERS.INDEX - 1
  999.       IF SYSOP THEN _
  1000.          GOTO 59320
  1001.       IF ASC(PRIVATE.CAT$) = 32 THEN _
  1002.          IF USER.SECURITY.LEVEL < VAL(PRIVATE.CAT$) THEN _
  1003.             GOTO 59306 _
  1004.          ELSE GOTO 59308
  1005.       IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
  1006.          GOTO 59306
  1007. 59308 L = TRUE
  1008.       FILNAME$ = PERSONAL.DRVPATH$ + _
  1009.                  LEFT$(PART.TO.PRINT$,12)
  1010. 59320 A$ = PART.TO.PRINT$                                            ' KG052003
  1011.       CALL COLORDIR (A$,"Y")                                         ' KG052003
  1012.       IF PERSONAL.STATUS$ = "*" AND LEFT$(A$,1) <> " " THEN _        ' KG052003
  1013.          A$ = "*" + A$ _                                             ' KG052003
  1014.       ELSE A$ = " " + A$                                             ' KG052003
  1015.       IF LOCAL.USER THEN _
  1016.          GOTO 59322
  1017.       CALL EOFCOMM (CHAR%)
  1018.       IF CHAR% <> -1 THEN _
  1019.          GOTO 59323            ' comm port input
  1020. 59322 KEYBOARD.STACK$ = INKEY$
  1021.       IF KEYBOARD.STACK$ = "" THEN _  ' no keyboard input
  1022.          CALL QTPUT1 (A$) : _
  1023.          GOTO 59324
  1024. 59323 SUBROUTINE.PARAMETER = 1
  1025.       CALL TPUT
  1026.       IF RET THEN _
  1027.          GOTO 59303
  1028.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1029.          GOTO 59335
  1030. 59324 IF LINES.PRINTED <= MAX.PRINT THEN _
  1031.          GOTO 59306
  1032.       CALL TIMEREMAIN (TIME.REMAINING!)
  1033.       IF TIME.REMAINING! < 0.1 THEN _
  1034.          SUBROUTINE.PARAMETER = -1 : _
  1035.          GOTO 59335
  1036.       CALL CARRIER
  1037.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1038.          GOTO 59335
  1039.       IF NON.STOP THEN _
  1040.          GOTO 59306
  1041. 59325 IF PERS.INDEX > 0 THEN _
  1042.          A$ = "MORE: [Y],N,C or download what (* = new)" _
  1043.       ELSE GOTO 59303                                                ' KG082601
  1044.       NO.ADVANCE = TRUE
  1045.       MACRO.MIN = 99
  1046.       CALL POPCSTACK                                                 ' KG082601
  1047.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1048.          GOTO 59335
  1049.       NON.STOP = (NON.STOP OR INSTR(" Cc",B$) > 1)
  1050.       IF PERS.INDEX < 1 AND Q = 0 THEN _
  1051.          GOTO 59335
  1052.       CALL WIPELINE (78)
  1053.       IF NO THEN _
  1054.          GOTO 59303
  1055.       IF LEN(B$(ANS.INDEX)) > 2 THEN _                               ' KG082601
  1056.          GOTO 59304
  1057.       GOTO 59306
  1058. 59327 PERS.INDEX = LAST.REC        ' handle new files
  1059.       LAST.INDEX = 0                                                 ' KG082601
  1060.       WHILE PERS.INDEX > 0 AND  LAST.INDEX < UBOUND(B$)              ' KG082601
  1061.          GET 2,PERS.INDEX
  1062.          IF PERSONAL.CAT$ <> PRIVATE.CAT$ THEN _
  1063.             GOTO 59329
  1064.          IF PERSONAL.STATUS$ <> "*" THEN _
  1065.             GOTO 59329
  1066.          LAST.INDEX = LAST.INDEX + 1                                 ' KG082601
  1067.          I = LAST.INDEX                                              ' KG082601
  1068.          GOSUB 59336
  1069.          IF OK THEN _
  1070.             X$ = MID$(STR$(PERS.INDEX),2) : _
  1071.             B$(0) = B$(0) + _
  1072.                     X$ + _
  1073.                     SPACE$(5 - LEN(X$)) _
  1074.          ELSE LAST.INDEX = LAST.INDEX - 1                            ' KG082601
  1075. 59329    PERS.INDEX = PERS.INDEX - 1
  1076.       WEND
  1077.       IF LAST.INDEX = 0 THEN _                                       ' KG082601
  1078.          A$ = "No new files for you" : _
  1079.          CALL QTPUT1 (A$) : _
  1080.          GOTO 59303
  1081.       ANS.INDEX = 1                                                  ' KG082601
  1082.       GOTO 59332
  1083. 59330 I = ANS.INDEX              ' handle list of files              ' KG082601
  1084.       WHILE I <= LAST.INDEX                                          ' KG082601
  1085.          OK = FALSE
  1086.          J = LAST.REC + 1
  1087.          CALL ALLCAPS (B$(I))
  1088.          WHILE J > 1 AND NOT OK
  1089.             J = J - 1
  1090.             GET #2,J
  1091.             IF (PERSONAL.CAT$ = PRIVATE.CAT$ OR _
  1092.                (ASC(PRIVATE.CAT$) = 32 AND _
  1093.                 USER.SECURITY.LEVEL => VAL(PRIVATE.CAT$))) THEN _
  1094.                    OK = (B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1))
  1095.          WEND
  1096.          IF OK THEN _
  1097.             GOSUB 59336 : _
  1098.             IF OK THEN _
  1099.                X$ = MID$(STR$(J),2) : _
  1100.                B$(0) = B$(0) + _
  1101.                        X$ + _
  1102.                        SPACE$(5 - LEN(X$))
  1103.          IF NOT OK THEN _
  1104.             CALL QTPUT1 (B$(I) + " not found - omitted") : _
  1105.             FOR K = I + 1 TO LAST.INDEX : _                          ' KG082601
  1106.                B$(K - 1) = B$(K) : _
  1107.             NEXT : _
  1108.             LAST.INDEX = LAST.INDEX - 1 : _                          ' KG082601
  1109.             I = I - 1
  1110.          I = I + 1
  1111.       WEND
  1112.       IF LAST.INDEX = 0 THEN _                                       ' KG082601
  1113.          GOTO 59303
  1114. 59332 DOWNLOAD.FLAG = PERS.INDEX          ' set protocol
  1115.       DOWNLOADING = TRUE
  1116.       B = 1
  1117.       IF SELECTED.PROTOCOL$ = "" THEN _
  1118.          IF PERSONAL.PROTOCOL$ <> " " THEN _
  1119.             SELECTED.PROTOCOL$ = PERSONAL.PROTOCOL$
  1120.       IF SELECTED.PROTOCOL$ <> "" THEN _
  1121.          LAST.INDEX = LAST.INDEX + 1 : _                             ' KG082601
  1122.          B$(LAST.INDEX) = SELECTED.PROTOCOL$                         ' KG082601
  1123.       EXIT SUB
  1124. 59335 CLOSE 2
  1125.       EXIT SUB
  1126. 59336 B$(I) = LEFT$(PART.TO.PRINT$,INSTR(PART.TO.PRINT$," ") - 1)
  1127.       CALL RBBSFIND (PERSONAL.DRVPATH$ + B$(I),Z,K,L,M)
  1128.       OK = (Z = 0)
  1129.       IF OK THEN _
  1130.          B$(I) = PERSONAL.DRVPATH$ + B$(I) _
  1131.       ELSE K = 0 : _
  1132.            WHILE K < SUBDIR.COUNT AND NOT OK : _
  1133.               K = K + 1 : _
  1134.               CALL RBBSFIND (SUBDIR$(K) + B$(I),Z,X,L,M) : _
  1135.               OK = (Z=0) : _
  1136.            WEND : _
  1137.            IF OK THEN _
  1138.               B$(I) = SUBDIR$(K) + B$(I)
  1139.       RETURN
  1140.       END SUB
  1141. 59400 ' $SUBTITLE: 'LOGDOWN -- subroutine to record private downloads'
  1142. ' $PAGE
  1143. '
  1144. '  NAME    -- LOGDOWN
  1145. '
  1146. '  INPUTS  --   PARAMETER     MEANING
  1147. '
  1148. '  OUTPUTS --
  1149. '
  1150. '  PURPOSE -- Puts a "!" in place of an "*" in private directory
  1151. '             after downloaded
  1152. '
  1153.       SUB LOGDOWN (PRIVATE.DOWNLOAD,DWN.INDEX) STATIC
  1154.       IF NOT PRIVATE.DOWNLOAD THEN _
  1155.          EXIT SUB
  1156.       EN$ = PERSONAL.DIR$
  1157.       BX = &H4
  1158.       SUBROUTINE.PARAMETER = 9
  1159.       CALL FILELOCK
  1160.       L = 36 + MAX.DESC.LEN + PERSONAL.LEN
  1161.       CLOSE 2
  1162.       IF SHARE.IT THEN _
  1163.          OPEN EN$ FOR RANDOM SHARED AS #2 LEN=L _
  1164.       ELSE OPEN "R",2,PERSONAL.DIR$,L
  1165.       FIELD #2,L AS PERSONAL.REC$
  1166.       A = VAL(MID$(B$(0),5 * (DWN.INDEX - 1) + 1,5))
  1167.       GET #2,A
  1168.       MID$(PERSONAL.REC$,L-2,1) = "!"
  1169.       PUT #2,A
  1170.       CALL UNLKAPPND
  1171.       END SUB
  1172. 59450 ' $SUBTITLE: 'USERFACE - handles programmable user interface'
  1173. ' $PAGE
  1174. '
  1175. '  NAME    --  USERFACE
  1176. '
  1177. '  INPUTS  --  PARAMETER                   MEANING
  1178. '              GDEFAULT$            GRAPHICS DEFAULT TO USE
  1179. '              CURRENT.PUI$         PUI TO USE
  1180. '              EXPERT.USER          WHETHER CALL IN EXPERT MODE
  1181. '
  1182. '  OUTPUTS --  Q
  1183. '              B$()
  1184. '              Z$
  1185. '
  1186. '  PURPOSE --  When sysop overrides RBBS-PC's default user
  1187. '              interface (provides a MAIN.PUT), this routine
  1188. '              reads in the table of specifications, presents
  1189. '              the sysop menu, presents the prompt, verifies
  1190. '              that a valid option has been picked, determines
  1191. '              whether the option is another PUI, and passes
  1192. '              back choices to be processed.
  1193. '
  1194.       SUB USERFACE (GDEFAULT$) STATIC
  1195. 59455 IF PREV.PUI$ = CURRENT.PUI$ THEN _
  1196.          GOTO 59458
  1197. 59456 FILE.NAME$ = CURRENT.PUI$
  1198.       CALL GRAPHIC (GDEFAULT$,FILE.NAME$)
  1199.       IF NOT OK THEN _
  1200.          CALL UPDTCALR ("Missing menu " + CURRENT.PUI$,2) : _
  1201.          CURRENT.PUI$ = PREV.PUI$ : _
  1202.          GOTO 59456
  1203.       PREV.PUI$ = CURRENT.PUI$
  1204.       LINE INPUT #2,FILE.NAME$
  1205.       LINE INPUT #2,PRMPT$
  1206.       INPUT #2,VALID.CHOICE$,ACTUAL.COMMANDS$
  1207.       LINE INPUT #2,MENU.CHOICE$
  1208.       LINE INPUT #2,MENU.NAME$
  1209.       LINE INPUT #2,QUIT.COMMAND$
  1210.       LINE INPUT #2,QUIT.PROMPT$
  1211.       LINE INPUT #2,QUIT.SUBCOMMANDS$
  1212.       LINE INPUT #2,QUIT.MENUOPT$
  1213.       LINE INPUT #2,QUIT.MENUS$
  1214.       CALL GRAPHIC (GDEFAULT$,FILE.NAME$)
  1215.       CALL BRKFNAME (FILE.NAME$,MENU.DRVPATH$,X$,Y$,TRUE)
  1216.       MENU.TO.DISPLAY$ = FILE.NAME$
  1217.       J = INSTR(ORIG.COMMANDS$,"?")
  1218.       IF J < 1 THEN _
  1219.          X$ = "" _
  1220.       ELSE X$ = MID$(ALL.OPTS$,J,1)
  1221. 59458 IF EXPERT.USER THEN _
  1222.          GOTO 59461
  1223. 59460 NON.STOP = (PAGE.LENGTH < 1)                                   ' KG060304
  1224.       CALL BUFFILE (MENU.TO.DISPLAY$,X)
  1225. 59461 A$ = PRMPT$
  1226.       TURBO.KEY = -TURBO.KEY.USER
  1227.       SUBROUTINE.PARAMETER = 1
  1228.       CALL TGET
  1229.       IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
  1230.          EXIT SUB
  1231.       IF Q = 0 THEN _
  1232.          GOTO 59458
  1233. 59462 Z$ = B$(1)
  1234.       CALL ALLCAPS (Z$)
  1235.       J = INSTR(VALID.CHOICE$,Z$)
  1236.       IF J < 1 THEN _
  1237.          GOTO 59492
  1238.       Z$ = MID$(ACTUAL.COMMANDS$,J,1)
  1239.       B$(1) = Z$
  1240.       J = INSTR(MENU.CHOICE$,Z$)
  1241.       IF J > 0 THEN _
  1242.          CURRENT.PUI$ = MID$(MENU.NAME$,1 + (J - 1) * 7,7) : _
  1243.          GOTO 59490
  1244.       IF Z$ = X$ THEN _
  1245.          GOTO 59460
  1246.       IF Z$ <> QUIT.COMMAND$ THEN _
  1247.          EXIT SUB
  1248.       IF Q > 1 THEN _
  1249.          Y = 2 : _
  1250.          GOTO 59480
  1251. 59470 A$ = QUIT.PROMPT$
  1252.       TURBO.KEY = -TURBO.KEY.USER
  1253.       CALL TGET
  1254.       IF SUBROUTINE.PARAMETER = -1 OR FUNCTION.KEY <> 0 THEN _
  1255.          EXIT SUB
  1256.       IF Q = 0 THEN _
  1257.          GOTO 59458
  1258.       Y = 1
  1259. 59480 Z$ = B$(Y)
  1260.       CALL ALLCAPS (Z$)
  1261.       J = INSTR(QUIT.SUBCOMMANDS$,Z$)
  1262.       IF J < 1 THEN _
  1263.          GOTO 59470
  1264.       J = INSTR(QUIT.MENUOPT$,Z$)
  1265.       IF J > 0 THEN _ 'quit to submenu
  1266.          CURRENT.PUI$ = MID$(QUIT.MENUS$,1 + (J - 1) * 7,7) : _
  1267.          GOTO 59490
  1268.       IF Q = 1 THEN _  'valid but not menu - send to RBBS
  1269.          Q = 2 : _
  1270.          B$(2) = B$(1) : _
  1271.          B$(1) = QUIT.COMMAND$
  1272.       EXIT SUB
  1273. 59490 CALL REMOVE (CURRENT.PUI$," ")
  1274.       CURRENT.PUI$ = MENU.DRVPATH$ + _
  1275.                      CURRENT.PUI$ + _
  1276.                      ".PUI"
  1277.       GOTO 59455
  1278. 59492 CALL QTPUT1 (Z$ + " not valid choice")
  1279.       GOTO 59460
  1280.       END SUB
  1281. 59500 ' $SUBTITLE: 'SUBMENU -- subroutine to process menus'
  1282. ' $PAGE
  1283. '
  1284. '  NAME    -- SUBMENU
  1285. '
  1286. '  INPUTS  --   PARAMETER     MEANING
  1287. '             PASSED.PROMPT$  PROMPT TO DISPLAY
  1288. '             CURRENT.MENU$   NOVICE MENU TO DISPLAY
  1289. '             FRONT.OPT$      DRIVE/PATH/PREFIX OF FILE
  1290. '                             NEEDED FOR TYPED OPTION
  1291. '             BACK.OPT$       SUFFIX/EXTENSION OF FILE
  1292. '                             NEEDED WITH TYPED OPTION
  1293. '             RETURN.ON$      LETTERS CALLING PROGRAM WANTS
  1294. '                               CONTROL ON
  1295. '             GR.DEFAULT$     GRAPHICS DEFAULT TO USE
  1296. '             VERIFY.IN.MENU  WHETHER VERIFY OPTION IS IN MENU
  1297. '             ALL.MENU.OK     WHETHER CONTROL SHOULD RETURN
  1298. '                               WHEN IN MENU
  1299. '             ANS.INDEX       # OF COMMANDS IN TYPE AHEAD
  1300. '             REQUIRE.IN.MENU WHETHER OPTION MUST BE IN MENU
  1301. '
  1302. '  OUTPUTS -- Z$              OPTION PICKED
  1303. '             FILE.NAME$      NAME OF FILE SUPPORTING OPTION
  1304. '
  1305. '
  1306. '  PURPOSE -- Handles menus - including conference, bulletins,
  1307. '             doors, questionnaires.  Supports sub-menus (i.e.
  1308. '             an option on the menu that invokes another menu)
  1309. '
  1310.       SUB SUBMENU (PASSED.PROMPT$,CURRENT.MENU$,FRONT.OPT$, _
  1311.                   BACK.OPT$,RETURN.ON$,GR.DEFAULT$,VERIFY.IN.MENU, _
  1312.                   ALL.MENU.OK,REQUIRE.IN.MENU,BACK.OPT2$) STATIC
  1313. 59510 FILE.NAME$ = CURRENT.MENU$
  1314.       CALL BRKFNAME (CURRENT.MENU$,MNU.DRV$,X$,DF$,TRUE)
  1315.       MENU.FRONT$ = MNU.DRV$ + X$
  1316.       CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$)
  1317.       CURRENT.MENU.VER$ = FILE.NAME$
  1318.       STOP.INTERRUPTS = FALSE
  1319.       IF ANS.INDEX < LAST.INDEX OR EXPERT.USER THEN _                ' KG082501
  1320.          GOTO 59520                                                  ' KG082501
  1321. 59515 CALL BUFFILE (CURRENT.MENU.VER$,ANS.INDEX) 'show menu          ' KG082501
  1322. 59520 A$ = PASSED.PROMPT$            'get response                   ' KG081201
  1323.       CALL POPCSTACK                                                 ' KG081201
  1324.       IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
  1325.          EXIT SUB                                                    ' KG081201
  1326. 59530 Z$ = B$(ANS.INDEX)
  1327.       CALL ALLCAPS (Z$)
  1328.       IF INSTR(RETURN.ON$,Z$) THEN _  'check whether calling pgm wants
  1329.          EXIT SUB
  1330.       IF INSTR("LH?",Z$) THEN _       'check whether caller wants help
  1331.          GOTO 59515
  1332.       IF INSTR(Z$,".") > 0 THEN _
  1333.          GOTO 59532
  1334.       FPRE$ = FRONT.OPT$
  1335.       GOSUB 59538
  1336.       IF (BF < 2) AND (NOT OK) THEN _
  1337.          FPRE$ = MNU.DRV$ : _                                        ' KG061102
  1338.          GOSUB 59538 : _                                             ' KG061102
  1339.          IF NOT OK THEN _    ' support shared options                ' KG061102
  1340.             FPRE$ = MENU.FRONT$ : _                                  ' KG061102
  1341.             GOSUB 59538                                              ' KG061102
  1342.       IF NEW.MENU THEN _
  1343.          NEW.MENU = FALSE : _
  1344.          GOTO 59515
  1345.       IF OK THEN _
  1346.          EXIT SUB
  1347. 59532 IF INSTR(RETURN.ON$,LEFT$(Z$,1)) > 0 THEN _
  1348.          EXIT SUB
  1349.       GOSUB 59547
  1350.       GOTO 59515
  1351. 59538 FILNAME$ = FPRE$ + Z$
  1352.       CALL BADFILE (FILNAME$,BF)
  1353.       IF BF > 1 THEN _
  1354.          OK = FALSE : _
  1355.          RETURN
  1356.       FILE.NAME$ = FILNAME$ + _
  1357.                    BACK.OPT$
  1358.       CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$)
  1359.       IF NOT OK THEN _
  1360.          IF BACK.OPT2$ <> "" THEN _
  1361.             FILE.NAME$ = FILNAME$ + _
  1362.                          BACK.OPT2$ : _
  1363.             CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$)
  1364.       IF OK THEN _
  1365.          IF SYSOP OR (NOT REQUIRE.IN.MENU) THEN _
  1366.             RETURN _
  1367.          ELSE CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND) : _
  1368.               IF FOUND THEN _
  1369.                  RETURN _
  1370.               ELSE GOTO 59540
  1371.       IF (NOT VERIFY.IN.MENU) THEN _
  1372.          GOTO 59540
  1373.       CALL WORDINFILE (CURRENT.MENU$,Z$,FOUND)  'verify against menu itself
  1374.       IF FOUND THEN _
  1375.          IF ALL.MENU.OK THEN _
  1376.             RETURN
  1377. 59540 X$ = FPRE$ + _
  1378.            Z$ + _
  1379.            ".MNU" 'check whether option is a menu
  1380.       FILE.NAME$ = X$
  1381.       CALL GRAPHIC (GR.DEFAULT$,FILE.NAME$)
  1382.       IF OK THEN _
  1383.          NEW.MENU = TRUE : _
  1384.          CURRENT.MENU.VER$ = FILE.NAME$ : _
  1385.          CURRENT.MENU$ = X$ : _
  1386.          CALL BRKFNAME (CURRENT.MENU$,MNU.DRV$,X$,DF$,TRUE) : _
  1387.          MENU.FRONT$ = MNU.DRV$ + X$ : _
  1388.          RETURN
  1389.       IF VERIFY.IN.MENU AND FOUND AND NOT REQUIRE.IN.MENU THEN _
  1390.          CALL UPDTCALR("Option " + Z$ + " on menu " + _
  1391.                        CURRENT.MENU$ + " but not found",1)
  1392.       RETURN
  1393. 59547 CALL QTPUT1 ("No such option " + Z$)
  1394.       RETURN
  1395. 59548 END SUB
  1396. 59600 ' $SUBTITLE: 'SETECHO -- subroutine to reset who echoes'
  1397. ' $PAGE
  1398. '
  1399. '  NAME    -- SETECHO
  1400. '
  1401. '  INPUTS  --   PARAMETER     MEANING
  1402. '               NEW.ECHO$   The new echo option
  1403. '               LOCAL.USER
  1404. '
  1405. '  OUTPUTS -- REMOTE.ECHO   Whether RBBS is to echo what a
  1406. '                           remote caller types
  1407. '
  1408. '  PURPOSE -- Resets who echos.  "R" is for RBBS to echo.
  1409. '             "I" is for intermediate host to echo.
  1410. '             "C" is for caller's communication pgm to echo.
  1411. '
  1412.       SUB SETECHO (NEW.ECHO$) STATIC
  1413.       IF NEW.ECHO$ = PREV.ECHO$ THEN _
  1414.          EXIT SUB
  1415.       IF NEW.ECHO$ = "R" THEN _
  1416.          REMOTE.ECHO = (NOT LOCAL.USER) _
  1417.       ELSE REMOTE.ECHO = FALSE
  1418.       IF LOCAL.USER THEN _
  1419.          GOTO 59602
  1420.       IF NEW.ECHO$ = "I" THEN _
  1421.           IF FOSSIL THEN _
  1422.              BYTES% = LEN(HOST.ECHO.ON$) : _
  1423.              CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.ON$) : _
  1424.              GOTO 59602 _
  1425.           ELSE PRINT #3,HOST.ECHO.ON$; : _
  1426.                GOTO 59602
  1427.       IF PREV.ECHO$ = "I" THEN _
  1428.           IF FOSSIL THEN _
  1429.              BYTES% = LEN(HOST.ECHO.OFF$) : _
  1430.              CALL FOSWRITE(COMPORT%,BYTES%,HOST.ECHO.OFF$) _
  1431.           ELSE PRINT #3,HOST.ECHO.OFF$;
  1432. 59602 PREV.ECHO$ = NEW.ECHO$
  1433.       END SUB
  1434. 59698 ' $SUBTITLE: 'MIMPORT -- subroutine to import a message'
  1435. ' $PAGE
  1436. '
  1437. '  NAME    -- MIMPORT
  1438. '
  1439. '  INPUTS  --   PARAMETER     MEANING
  1440. '               MAX.LINES     MAXIMUM # OF LINES
  1441. '               MAX.LEN       MAXIMUM LENGTH OF A LINE
  1442. '               NUM.LINES     NUMBER OF LINES ALREADY IN MESSAGE
  1443. '               LINE.ARA$     ARRAY OF LINES IN MESSAGE
  1444. '
  1445. '  OUTPUTS --   NUM.LINES
  1446. '               LINE.ARA$
  1447. '
  1448. '  PURPOSE -- Allows local user to append a text file to
  1449. '             a message.   Will word wrap if needed.
  1450. '
  1451.       SUB MIMPORT (MAX.LINES,MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
  1452.       IF NOT (LOCAL.USER OR SYSOP) THEN _
  1453.          CALL QTPUT1 ("Only for SYSOPS/local users") : _
  1454.          EXIT SUB
  1455. 59700 SUBROUTINE.PARAMETER = 1
  1456.       A$ = "Import what file" + PRESS.ENTER$
  1457.       CALL TGET
  1458.       IF SUBROUTINE.PARAMETER = -1 OR Q = 0 THEN _
  1459.          EXIT SUB
  1460.       CALL FINDIT (B$)
  1461.       IF NOT OK THEN _
  1462.          CALL QTPUT1 (B$ + " not found") : _
  1463.          GOTO 59700
  1464.       WHILE NOT EOF(2) AND NUM.LINES < MAX.LINES
  1465.          NUM.LINES = NUM.LINES + 1
  1466.          LINE INPUT #2,LINE.ARA$(NUM.LINES)
  1467.       WEND
  1468.       CLOSE 2
  1469.       CALL WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$())
  1470.       END SUB
  1471. 59703 ' $SUBTITLE: 'WORDWRAP -- subroutine to wrap lines in a message'
  1472. ' $PAGE
  1473. '
  1474. '  NAME    -- WORDWRAP
  1475. '
  1476. '  INPUTS  --   PARAMETER     MEANING
  1477. '               MAX.LEN       MAXIMUM LENGTH OF A SINGLE LINE
  1478. '               NUM.LINES     NUMBER OF LINES IN A MESSAGE
  1479. '               LINE.ARA$     ALL THE LINES IN THE MESSAGE
  1480. '
  1481. '  OUTPUTS --   NUM.LINES
  1482. '               LINE.ARA$
  1483. '
  1484. '  PURPOSE -- Batch adjusts a message, wrapping lines if
  1485. '             needed.  Preserves paragraph structure.
  1486. '
  1487.       SUB WORDWRAP (MAX.LEN,NUM.LINES,LINE.ARA$(1)) STATIC
  1488.       J = 1
  1489.       WHILE J <= NUM.LINES
  1490.          REFORMATTED = FALSE                                         ' KG080701
  1491. 59704    CALL TRIMTRAIL (LINE.ARA$(J)," ")
  1492.          K = LEN(LINE.ARA$(J))
  1493.          IF K <= MAX.LEN THEN _
  1494.             GOTO 59705
  1495.          CALL FINDLAST (LINE.ARA$(J)," ",LAST.POS,HOW.MANY)
  1496.          CALL ANYBUT (LINE.ARA$(J),1,">",X)                          ' KG061202
  1497.          CALL ANYBUT (LINE.ARA$(J+1),1,">",TEMP)                     ' KG061202
  1498.          IF LEFT$(LINE.ARA$(J + 1),2) = "  " OR ((TEMP > 0) AND X <> TEMP) THEN _ ' KG061202
  1499.             FOR K = NUM.LINES TO J + 1 STEP -1 : _
  1500.                LINE.ARA$(K + 1) = LINE.ARA$(K) : _
  1501.             NEXT : _
  1502.             NUM.LINES = NUM.LINES + 1 : _
  1503.             LINE.ARA$(J + 1) = ""
  1504.          IF X > 1 THEN _                                             ' KG061202
  1505.             IF MID$(LINE.ARA$(J),X,1) = " " THEN _                   ' KG061202
  1506.                X = X + 1                                             ' KG061202
  1507.          X$ = LEFT$(LINE.ARA$(J),X-1)                                ' KG061202
  1508.          IF LAST.POS < 1 THEN _
  1509.             LINE.ARA$(J + 1) = X$ + MID$(LINE.ARA$(J),MAX.LEN) + MID$(LINE.ARA$(J + 1),X) : _ ' KG061202
  1510.             LINE.ARA$(J) = LEFT$(LINE.ARA$(J),MAX.LEN - 1) + "-" _
  1511.          ELSE B$ = LEFT$(" ", - (LEN(LINE.ARA$(J + 1)) > 0)) : _
  1512.               LINE.ARA$(J + 1) = X$ + MID$(LINE.ARA$(J),LAST.POS + 1) + B$ + MID$(LINE.ARA$(J + 1),X) : _ ' KG061202
  1513.               LINE.ARA$(J) = LEFT$(LINE.ARA$(J),LAST.POS - 1)
  1514.          REFORMATTED = TRUE                                          ' KG080701
  1515.          GOTO 59704
  1516. 59705    IF REFORMATTED THEN _                                       ' KG080701
  1517.             IF J = NUM.LINES THEN _                                  ' KG080701
  1518.                NUM.LINES = NUM.LINES + 1                             ' KG080701
  1519.          J = J + 1
  1520.       WEND                                                           ' KG080701
  1521.       END SUB
  1522. 59750 ' $SUBTITLE: 'SETABORT -- subroutine to set a time-limit'
  1523. ' $PAGE
  1524. '
  1525. '  NAME    -- SETABORT
  1526. '
  1527. '  INPUTS  --   PARAMETER     MEANING
  1528. '             SECONDS.TO.ADD  # SECONDS AFTER CURRENT TIME
  1529. '                             WHEN TIME LIMIT IS TO EXPIRE
  1530. '
  1531. '  OUTPUTS --  ABORT.TIME!    THE TIME (IN SECONDS AFTER MIDNIGHT)
  1532. '                             WHEN TIME LIMIT EXPIRES
  1533. '
  1534. '  PURPOSE -- Sets a time limit in units of seconds after
  1535. '             midnight after which a time limit will expire.
  1536. '             Calling program passes number of seconds that can
  1537. '             elapse before time-limit is reached.
  1538. '
  1539.       SUB SETABORT (ABORT.TIME!,SECONDS.TO.ADD) STATIC
  1540.       CALL FINDTIME (ABORT.TIME!)
  1541.       ABORT.TIME! = ABORT.TIME! + SECONDS.TO.ADD
  1542.       END SUB
  1543. 59760 ' $SUBTITLE: 'ANYBUT -- subroutine to find where a word begins'
  1544. ' $PAGE
  1545. '
  1546. '  NAME    -- ANYBUT
  1547. '
  1548. '  INPUTS  --   PARAMETER     MEANING
  1549. '               STRNG$        STRING TO SEARCH FOR WORDS
  1550. '               BEG%          BYTE POSITION IN STRNG$ TO
  1551. '                                BEGIN SEARCHING
  1552. '               SKIP.CHARS$   CHARACTERS TO SKIP OVER WHEN
  1553. '                                SEARCHING
  1554. '
  1555. '  OUTPUTS --   WHEREIS%      BYTES POSITION IN STRNG$ WHERE
  1556. '                             WORD BEGINS
  1557. '
  1558. '  PURPOSE -- Parser.   Finds where a "word" begins, where
  1559. '             any character will be accepted as the beginning of a
  1560. '             word except those listed in SKIP.CHAR$
  1561. '
  1562.       SUB ANYBUT (STRNG$, BEG%, SKIP.CHARS$, WHEREIS%) STATIC
  1563.       X$ = STRNG$ + _
  1564.            CHR$(0)
  1565.       WHEREIS% = BEG%
  1566.       IF WHEREIS% < 1 THEN _
  1567.          WHEREIS% = 1
  1568.       WHILE INSTR(SKIP.CHARS$, MID$(X$, WHEREIS%, 1)) > 0
  1569.          WHEREIS% = WHEREIS% + 1
  1570.       WEND
  1571.       IF WHEREIS% > LEN(STRNG$) THEN _
  1572.          WHEREIS% = 0
  1573.       END SUB
  1574. 59770 ' $SUBTITLE: 'FINDEND -- subroutine to find where a word ends'
  1575. ' $PAGE
  1576. '
  1577. '  NAME    -- FINDEND
  1578. '
  1579. '  INPUTS  --   PARAMETER     MEANING
  1580. '               STRNG$        STRING TO SEARCH FOR WORDS
  1581. '               BEG%          POSITION IN STRNG$ TO BEGIN SEARCH
  1582. '               STOP.WITH$    CHARACTERS THAT TERMINATE A WORD
  1583. '
  1584. '  OUTPUTS      WHEREIS%      POSITION IN STRNG$ WHERE WORD ENDS
  1585. '                             (I.E. THE LAST CHARACTER OF THE WORD)
  1586. '
  1587. '  PURPOSE -- Parser.   Finds where a "word" ends, where
  1588. '             any character will be counted as in a word
  1589. '             except for those in STOP.WITH$ or when the end of
  1590. '             the string is found.
  1591. '
  1592.       SUB FINDEND (STRNG$, BEG%, STOP.WITH$, WHEREIS%) STATIC
  1593.       B = BEG%
  1594.       IF B < 1 THEN _
  1595.          B = 1
  1596.       IF B > LEN(STRNG$) THEN _
  1597.          X$ = STOP.WITH$ _
  1598.       ELSE X$ = MID$(STRNG$, B) + _
  1599.                 STOP.WITH$
  1600.       I = 1
  1601.       X = INSTR(STOP.WITH$, MID$(X$, I, 1))
  1602.       WHILE X = 0
  1603.          I = I + 1
  1604.          X = INSTR(STOP.WITH$, MID$(X$, I, 1))
  1605.       WEND
  1606.       WHEREIS% = I - 1 + B - 1
  1607.       END SUB
  1608. 59780 ' $SUBTITLE: 'GETALL -- subroutine to create directory list'
  1609. ' $PAGE
  1610. '
  1611. '  NAME    -- GETALL
  1612. '
  1613. '  INPUTS  --   PARAMETER     MEANING
  1614. '               LOOK.IN$      NAME OF FILE TO SEARCH
  1615. '               DIR.EXT$      MAIN DIRECTORY EXTENSION TO USE
  1616. '               START.POS     LAST POSITION USED IN ARRAY
  1617. '
  1618. '  OUTPUTS      START.POS     LAST ELEMENT USED IN ARRAY
  1619. '               LOAD.INTO$    ARRAY TO LOAD ELEMENTS FOUND
  1620. '
  1621. '  PURPOSE -- Creates a list (LOAD.INTO$) of all directories
  1622. '             found in directory of directories (LOOK.IN$).
  1623. '             Used for determining what gets listed when doing
  1624. '             an "ALL" to determinate what separate directories
  1625. '             to display.  Directory name must be all caps
  1626. '             and followed by a space or dash.
  1627. '
  1628.       SUB GETALL (LOOK.IN$, LOAD.INTO$(1), DIR.EXT$, START.POS) STATIC
  1629.       IF MASTER.DIRECTORY.NAME$ <> "" THEN _
  1630.          START.POS = START.POS + 1 : _
  1631.          LOAD.INTO$(START.POS) = MASTER.DIRECTORY.NAME$ : _
  1632.          EXIT SUB
  1633.       CALL FINDIT(LOOK.IN$)
  1634.       IF NOT OK THEN _
  1635.          EXIT SUB
  1636.       MAX.LOAD = UBOUND(LOAD.INTO$, 1)
  1637.       START.SORT = START.POS + 1
  1638.       WHILE NOT EOF(2) AND START.POS < MAX.LOAD
  1639.          LINE INPUT #2, A$
  1640.          LAST.POS = LEN(A$)
  1641.          CALL ANYBUT(A$, 1, " ", X)
  1642.          WHILE X > 0 AND X < LAST.POS AND START.POS < MAX.LOAD
  1643.             CALL FINDEND(A$, X + 1, " -.", Y)
  1644.             L = Y - X + 1
  1645.             IF L > 8 THEN _
  1646.                GOTO 59782
  1647.             B$ = MID$(A$, X, L)
  1648.             IF B$ = "ALL" OR (LEN(B$)=1 AND INSTR("HL?",B$) > 0) THEN _ ' KG081201
  1649.                GOTO 59782
  1650.             CALL BADFILECHAR (B$,I)
  1651.             IF NOT I THEN _
  1652.                GOTO 59782
  1653.             Z$ = LEFT$(B$,1)
  1654.             IF (Z$ >= "0" AND Z$ <= "9") OR _
  1655.                (Z$ >= "A" AND Z$ <= "Z") THEN _
  1656.                   Z$ = B$ : _
  1657.                   CALL ALLCAPS (Z$) : _
  1658.                   IF Z$ = B$ THEN _
  1659.                      LOAD.INTO$(START.POS + 1) = Z$ : _
  1660.                      IF USE.DIR.ORDER THEN _
  1661.                         I = START.SORT : _
  1662.                         WHILE LOAD.INTO$(I) <> Z$ : _
  1663.                            I = I + 1 : _
  1664.                         WEND : _
  1665.                         START.POS = START.POS - (I > START.POS) _
  1666.                      ELSE _
  1667.                         I = START.SORT : _
  1668.                         Z = VAL(Z$) : _
  1669.                         WHILE VAL(LOAD.INTO$(I)) < Z : _
  1670.                            I = I + 1 : _
  1671.                         WEND : _
  1672.                         WHILE VAL(LOAD.INTO$(I)) = Z AND LOAD.INTO$(I) < Z$ AND I <= START.POS : _
  1673.                            I = I + 1 : _
  1674.                         WEND : _
  1675.                         IF I > START.POS THEN _
  1676.                            START.POS = I _
  1677.                         ELSE IF Z$ <> LOAD.INTO$(I) THEN _
  1678.                                 FOR J = START.POS TO I STEP -1 : _
  1679.                                    LOAD.INTO$(J + 1) = LOAD.INTO$(J) : _
  1680.                                 NEXT : _
  1681.                                 LOAD.INTO$(I) = Z$ : _
  1682.                                 START.POS = START.POS + 1
  1683. 59782       CALL ANYBUT(A$, Y + 1, " ", X)
  1684.          WEND
  1685.       WEND
  1686.       CLOSE 2
  1687.       END SUB
  1688. 59790 ' $SUBTITLE: 'FINDFILE -- subroutine to find a file'
  1689. ' $PAGE
  1690. '
  1691. '  NAME    --  FINDFILE
  1692. '
  1693. '  INPUTS  --  PARAMETER         MENANING
  1694. '               FILNAME$         NAME OF FILE TO LOOK FOR
  1695. '               FEXISTS          WHETHER FILE EXISTS
  1696. '
  1697. '  OUTPUTS --  RETURNED.VALUE    VALUE RETURNED
  1698. '                                TRUE  = FILE EXISTS
  1699. '                                FALSE = FILE DOES NOT EXIST
  1700. '
  1701. '  PURPOSE --  Determine whether passed file FILNAME$ exists
  1702. '              Unlike, FINDIT, this routine does not open any
  1703. '              file and, hence, does not create one in determining
  1704. '              whether a file exists.
  1705. '
  1706.       SUB FINDFILE (FILNAME$,FEXISTS) STATIC
  1707.       CALL BADFILECHAR (FILNAME$,FEXISTS)
  1708.       IF FEXISTS THEN _
  1709.          CALL RBBSFIND (FILNAME$,Z,Y,M,D) : _
  1710.          FEXISTS = (Z = 0)
  1711.       END SUB
  1712. 59800 ' $SUBTITLE: 'BADFILECHAR -- checks file for illegal char'
  1713. ' $PAGE
  1714. '
  1715. '  NAME    --  BADFILECHAR
  1716. '
  1717. '  INPUTS  --  PARAMETER         MEANING
  1718. '               FILNAME$         NAME OF FILE TO CHECK
  1719. '
  1720. '  OUTPUTS --  IS.OK            WHETHER NAME OK
  1721. '
  1722. '  PURPOSE --  Part of test for file's existence.  If bad
  1723. '              character in name, can't exist.
  1724. '
  1725.       SUB BADFILECHAR (FILNAME$,IS.OK) STATIC
  1726.       L = LEN(FILNAME$)
  1727.       IF L > 2 THEN _
  1728.          IF INSTR(3,FILNAME$,":") > 0 THEN _
  1729.             IS.OK = FALSE : _
  1730.             EXIT SUB
  1731.       X$ = FILNAME$ + "="
  1732.       I = 1
  1733.       WHILE INSTR("/[]|<>+=*?;,",MID$(X$,I,1)) = 0 AND ASC(MID$(X$,I)) < 128
  1734.          I = I + 1
  1735.       WEND
  1736.       IS.OK = I > L
  1737.       END SUB
  1738. '
  1739. 59850 ' $SUBTITLE: 'CONFMAIL -- quickly checks mail waiting'
  1740. ' $PAGE
  1741. '
  1742. '  NAME    -- CONFMAIL
  1743. '
  1744. '  INPUTS  -- PARAMETER        MEANING
  1745. '         SKIP.CONFIRM         Whether to skip confirm of option
  1746. '         CONFMAIL.LIST$       File of user/message pairs to check
  1747. '         ACTIVE.USER.FILE$    Active user file (restored on exit)
  1748. '         ACTIVE.MESSAGE.FILE$ Active msg file (restored)
  1749. '  OUTPUTS -- None
  1750. '
  1751. '  PURPOSE -- Quicking scans message header record to get
  1752. '             last msg # and user record to get whether any
  1753. '             new mail and last msg read, reports both, using
  1754. '             highlighting if new mail to caller.
  1755. '
  1756.       SUB CONFMAIL (MAILCHECK.CONFIRM) STATIC
  1757.       SKIP.JOIN.UNJOIN = NON.STOP                                    ' KG071906
  1758.       IF START.HASH = 1 AND USER.FILE.INDEX > 0 THEN _
  1759.          CALL FINDIT (CONFMAIL.LIST$) _
  1760.       ELSE OK = FALSE
  1761.       IF NOT OK THEN _
  1762.          EXIT SUB
  1763.       IF MAILCHECK.CONFIRM THEN _
  1764.          A$ = "Check conferences for mail ([Y],N)" : _               ' KG081201
  1765.          TURBO.KEY = -TURBO.KEY.USER : _
  1766.          CALL POPCSTACK : _                                          ' KG081201
  1767.          IF NO OR SUBROUTINE.PARAMETER < 0 THEN _
  1768.             EXIT SUB
  1769.       CALL SKIPLINE (1)
  1770.       CALL QTPUT1 ("Checking Message Bases since last on...")
  1771.       ANY.MAIL = FALSE
  1772.       STOP.INTERRUPTS = FALSE
  1773.       A1$ = ACTIVE.USER.FILE$
  1774.       M$ = ACTIVE.MESSAGE.FILE$
  1775.       TEMP.INDIV.VALUE$ = ""
  1776.       SUIX = USER.FILE.INDEX
  1777.       USER.RECORD.HOLD$ = USER.RECORD$
  1778.       OK = TRUE
  1779. 59852 IF EOF(2) OR NOT OK THEN _
  1780.          GOTO 59854
  1781.          CALL READANY
  1782.          ACTIVE.USER.FILE$ = A$
  1783.          CALL READANY
  1784.          IF EC > 0 THEN _
  1785.             GOTO 59854
  1786.          ACTIVE.MESSAGE.FILE$ = A$
  1787.          CALL FINDFILE (ACTIVE.USER.FILE$,OK)
  1788.          IF NOT OK THEN _
  1789.             GOTO 59854
  1790.          CALL OPENUSER (HIGHEST.USER.RECORD)
  1791.          FIELD 5, 128 AS USER.RECORD$
  1792.          CALL FINDFILE (ACTIVE.MESSAGE.FILE$,OK)
  1793.          IF NOT OK THEN _
  1794.             GOTO 59854
  1795.          CALL FINDUSER (ORIG.USER.NAME$,"",START.HASH,LEN.HASH,_
  1796.                         0,0,HIGHEST.USER.RECORD,_
  1797.                         FOUND,UFI,SL)
  1798.          IF NOT FOUND THEN _
  1799.             GOTO 59852
  1800.          CALL OPENMSG
  1801.          FIELD 1, 128 AS MESSAGE.RECORD$
  1802.          GET 1,1
  1803.          ANY.MAIL = TRUE
  1804.          X = CVI(MID$(USER.RECORD$,57,2))
  1805.          X = (X AND 512) > 0
  1806.          CALL BRKFNAME (ACTIVE.USER.FILE$,X$,Y$,Z$,FALSE)
  1807.          A = CVI(MID$(USER.RECORD$,51,2))
  1808.          B = VAL(LEFT$(MESSAGE.RECORD$,8))
  1809.          Z = (B - A)
  1810.          IF Z < 0 THEN _                                             ' KG051701
  1811.             A = 0 : _                                                ' KG051701
  1812.             Z = B _                                                  ' KG051701
  1813.          ELSE IF Z = 0 THEN _                                        ' KG051701
  1814.                  X = FALSE                                           ' KG051701
  1815.          A$ = MID$(STR$((B > A) * Z),2)
  1816.          SL = LEN(A$)
  1817.          A$ = SPACE$(-(SL<4) * (4-SL)) + A$                          ' KG082503
  1818.          SL = LEN(Y$)
  1819.          CONF$ = LEFT$(Y$,SL-1)
  1820.          Y$ = CONF$ + SPACE$(-(SL<8) * (8-SL))
  1821.          IF X THEN _
  1822.             X$ = EMPHASIZE.ON$ : _
  1823.             Z$ = EMPHASIZE.OFF$ _
  1824.          ELSE X$ = "" : _
  1825.               Z$ = ""
  1826.          A$ = Y$ + ": " + A$ + " new message(s): " + _
  1827.               X$ + MID$(" None *Some*",-6 * X + 1,6) + " to you" + Z$
  1828.          SUBROUTINE.PARAMETER = 5
  1829.          CALL TPUT
  1830.          IF SKIP.JOIN.UNJOIN THEN _                                  ' KG071907
  1831.             CALL ASKMORE ("",TRUE,TRUE,X,TRUE) : _
  1832.             GOTO 59853
  1833.          TURBO.KEY = -TURBO.KEY.USER
  1834.          CALL ASKMORE (",J)oin,U)njoin",TRUE,FALSE,X,FALSE)
  1835.          IF NO THEN _
  1836.             GOTO 59854
  1837.          X$ = LEFT$(B$(1),1)
  1838.          CALL ALLCAPS (X$)
  1839.          IF X$ = "U" THEN _
  1840.             LSET USER.RECORD$ = CHR$(0) + "deleted user" : _
  1841.             USER.FILE.INDEX = UFI : _
  1842.             SUBROUTINE.PARAMETER = 6 : _
  1843.             CALL FILELOCK : _
  1844.             PUT 5, UFI : _
  1845.             SUBROUTINE.PARAMETER = 8 : _
  1846.             CALL FILELOCK : _
  1847.             CALL QTPUT1 ("Omitted you from " + CONF$) _
  1848.          ELSE IF X$ = "J" THEN _
  1849.                  HOME.CONFERENCE$ = CONF$ : _
  1850.                  GOTO 59854
  1851. 59853 IF NOT RET THEN _
  1852.          GOTO 59852
  1853. 59854 ACTIVE.USER.FILE$ = A1$
  1854.       CALL OPENUSER (HIGHEST.USER.RECORD)
  1855.       FIELD 5, 128 AS USER.RECORD$
  1856.       IF (NOT RET) AND NOT ANY.MAIL THEN _
  1857.          CALL QTPUT1 ("No new personal mail")
  1858.       USER.FILE.INDEX = SUIX
  1859.       LSET USER.RECORD$ = USER.RECORD.HOLD$
  1860.       ACTIVE.MESSAGE.FILE$ = M$
  1861.       CALL OPENMSG
  1862.       FIELD 1, 128 AS MESSAGE.RECORD$
  1863.       GET 1,1
  1864.       NON.STOP = (PAGE.LENGTH > 0)
  1865.       END SUB
  1866. 59858 ' $SUBTITLE: 'ASKMORE -- pauses when possible screen full'
  1867. ' $PAGE
  1868. '
  1869. '  NAME    -- ASKMORE
  1870. '
  1871. '  INPUTS  --   PARAMETER     MEANING
  1872. '               EXTRA.PRMPT$  STRING TO ADD TO MORE PROMPT AT END
  1873. '               OVERWRITE     WHETHER TO WIPE AWAY PROMPT
  1874. '
  1875. '  OUTPUTS --   B$()
  1876. '               NO
  1877. '
  1878. '  PURPOSE -- Determines whether need to pause if screen full.
  1879. '             And, if so, asks the appropriate question.  If non-
  1880. '             stop, at least check for carrier present.
  1881. '
  1882.       SUB ASKMORE (EXTRA.PRMPT$, OVERWRITE, CHECK.LINES,ABORT.INDEX,CANT.INTERRUPT) STATIC
  1883.       NO = FALSE
  1884.       IF CHECK.LINES THEN _
  1885.          X = -DISPLAY.AS.UNIT*UNIT.COUNT -(NOT DISPLAY.AS.UNIT)*LINES.PRINTED : _
  1886.          IF X < PAGE.LENGTH OR (PAGE.LENGTH = 0) THEN _
  1887.             Q = 0 : _
  1888.             EXIT SUB
  1889.       IF ONE.STOP THEN _
  1890.          ONE.STOP = FALSE : _
  1891.          NON.STOP = TRUE : _
  1892.          GOTO 59860
  1893.       IF NON.STOP THEN _
  1894.          LINES.PRINTED = 0 : _
  1895.          CALL CHKCARRIER : _                                         ' KG061203
  1896.          IF KEYBOARD.STACK$ = "" AND COMMPORT.STACK$ = "" THEN _
  1897.             EXIT SUB _
  1898.          ELSE NON.STOP = FALSE
  1899. 59860 CALL QTPUT (EMPHASIZE.OFF$,0)
  1900.       IF CANT.INTERRUPT THEN _
  1901.          TURBO.KEY = 2 : _
  1902.          A$ = "Press Any Key to continue" _
  1903.       ELSE A$ = MORE.PROMPT$ + EXTRA.PRMPT$ + LEFT$(">",-EXPERT.USER)
  1904.       X = LEN(A$) + 2
  1905.       NO.ADVANCE = OVERWRITE
  1906.       SUBROUTINE.PARAMETER = 1
  1907.       IF EXTRA.PRMPT$ = "" AND TURBO.KEY = 0 THEN _
  1908.          TURBO.KEY = -TURBO.KEY.USER
  1909.       MACRO.MIN = 2
  1910.       CALL TGET
  1911.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1912.         EXIT SUB
  1913.       TURBO.KEY = FALSE
  1914.       DF$ = B$                                                       ' KG072701
  1915.       CALL ALLCAPS (DF$)                                             ' KG072701
  1916.       I = INSTR(";C;A;",";"+DF$+";")                                 ' KG072701
  1917.       IF I = 1 THEN _                                                ' KG072701
  1918.          NON.STOP = TRUE : _                                         ' KG072701
  1919.          Q = 0                                                       ' KG072701
  1920.       CALL WIPELINE (X + LEN(B$))
  1921.       IF NOT HIGHLIGHT.OFF THEN _                                    ' MZ061401
  1922.          CALL QTPUT (LAST.SMART.COLOR$,0)                            ' MZ061401
  1923.       IF CANT.INTERRUPT THEN _
  1924.          NO = FALSE : _
  1925.          EXIT SUB
  1926.       IF I = 3 THEN _                                                ' KG072701
  1927.          ABORT.INDEX = 32000
  1928.       IF NO THEN _
  1929.          KEYBOARD.STACK$ = "" : _
  1930.          COMMPORT.STACK$ = "" : _                                    ' MZ060302
  1931.          LAST.SMART.COLOR$ = ""                                      ' MZ060302
  1932.       END SUB
  1933. 59880 ' $SUBTITLE: 'COMPDATE -- subroutine to compute elased days'
  1934. ' $PAGE
  1935. '
  1936. '  NAME    -- COMPDATE
  1937. '
  1938. '  INPUTS  --   PARAMETER     MEANING
  1939. '                   YY        YEAR
  1940. '                   MM        MONTH
  1941. '                   DD        DAY
  1942. '                 RESULT!    LOCATION TO PLACE THE RESULT
  1943. '
  1944. '  OUTPUTS -- RESULT!        COMPUTE COMPUTATIONAL DATE
  1945. '
  1946. '  PURPOSE -- Computes a computational date from YEAR, MONTH, DAY.
  1947. '             Results may be used to compute the number of elapsed
  1948. '             days between two dates.  You may pass a 2 or 4 digit
  1949. '             year, but for meaningful results, be consistent
  1950. '
  1951.       SUB COMPDATE (YY,MM,DD,RESULT!) STATIC
  1952.       IF MM < 1 OR MM > 12 THEN _
  1953.          MM = 1
  1954.       RESULT! = YY * 365.0 + _
  1955.                 INT((YY - 1) / 4) + _
  1956.                 (MM - 1) * 28 + _
  1957.                 VAL(MID$("000303060811131619212426",(MM - 1) * 2 + 1,2)) - _
  1958.                 ((MM > 2) AND ((YY MOD 4) = 0)) + _
  1959.                 DD
  1960.       END SUB
  1961. 59890 ' $SUBTITLE: 'EXPDATE -- subroutine to display expiration date'
  1962. ' $PAGE
  1963. '
  1964. '  NAME    -- EXPDATE
  1965. '
  1966. '  INPUTS  --   PARAMETER           MEANING
  1967. '             REGISTRATION.DATE!    COMPUTATIONAL REGISTRATION DATE
  1968. '             REGISTRATION.PERIOD   DAYS IN REGISTRATION PERIOD
  1969. '
  1970. '  OUTPUTS -- EXP.DATE$             DISPLAYABLE EXPIRATION DATE
  1971. '
  1972. '  PURPOSE -- Computes/creates a displayable registration
  1973. '             expiration date using registration date and days in
  1974. '             registration period.
  1975. '
  1976.       SUB EXPDATE (REGISTRATION.DATE!,REGISTRATION.PERIOD,EXP.DATE$) STATIC
  1977.       EXPIRE.DATE! = REGISTRATION.DATE! + REGISTRATION.PERIOD
  1978.       EXPIRE.YEAR! = INT((EXPIRE.DATE! - EXPIRE.DATE! / 1461) / 365)
  1979.       EXPIRE.DAY% = EXPIRE.DATE! - (EXPIRE.YEAR! * 365 + INT((EXPIRE.YEAR! -1)/4))
  1980.       EXPIRE.MONTH% = -((EXPIRE.YEAR! MOD 4)<>0) * _
  1981.                       (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 59) - _
  1982.                       (EXPIRE.DAY% > 90) - (EXPIRE.DAY% >120) - _
  1983.                       (EXPIRE.DAY% > 151) - (EXPIRE.DAY% > 181) - _
  1984.                       (EXPIRE.DAY% > 212) - (EXPIRE.DAY% > 243) - _
  1985.                       (EXPIRE.DAY% > 273) - (EXPIRE.DAY% > 304) - _
  1986.                       (EXPIRE.DAY% > 334)) - ((EXPIRE.YEAR! MOD 4) = 0) * _
  1987.                       (1 - (EXPIRE.DAY% > 31) - (EXPIRE.DAY% > 60) - _
  1988.                       (EXPIRE.DAY% > 91) - (EXPIRE.DAY% >121) - _
  1989.                       (EXPIRE.DAY% > 152) - (EXPIRE.DAY% > 182) - _
  1990.                       (EXPIRE.DAY% > 213) - (EXPIRE.DAY% > 243) - _
  1991.                       (EXPIRE.DAY% > 274) - (EXPIRE.DAY% > 305) - _
  1992.                       (EXPIRE.DAY% > 335))
  1993.       EXPIRE.DAY% = (EXPIRE.DAY% - ((EXPIRE.MONTH% - 1) * 28 + _
  1994.          VAL(MID$("000303060811131619212426",(EXPIRE.MONTH% -1) * 2 + 1,2)))) + _
  1995.          ((EXPIRE.MONTH% > 2) AND ((EXPIRE.YEAR! MOD 4) = 0))
  1996.       EXP.DATE$ = RIGHT$("0" + MID$(STR$(EXPIRE.MONTH%),2),2) + _
  1997.                   "/" + _
  1998.                   RIGHT$("0" + MID$(STR$(EXPIRE.DAY%),2),2) + _
  1999.                   "/" + _
  2000.                   RIGHT$(STR$(EXPIRE.YEAR!),2)
  2001.       END SUB
  2002. 59920 ' $SUBTITLE: 'COLORDIR - builds a color FMS directory string'
  2003. ' $PAGE
  2004. '
  2005. '  NAME    --  COLORDIR
  2006. '
  2007. '  INPUTS  --  PARAMETER                   MEANING
  2008. '               STRNG$              String to alter
  2009. '               FMS.DIR$            "Y" FOR FMS DIR
  2010. '                                   "N" FOR PERSONAL DOWNLOADS
  2011. '
  2012.       SUB COLORDIR (STRNG$,FMS.DIR$) STATIC
  2013.       IF GR < 2 THEN _
  2014.          EXIT SUB
  2015.       IF FMS.DIR$ = "N" THEN _
  2016.          GOTO 59921
  2017. '
  2018. ' INSERT COLOR FOR FILENAME
  2019. '
  2020.       ON INSTR("\ *",LEFT$(STRNG$,1)) GOTO 59924,59922,59923
  2021. 59921 STRNG$ = DR.1$ + LEFT$(STRNG$,13) + DR.2$ + MID$(STRNG$,14,10) + _
  2022.                DR.3$ + MID$(STRNG$,24,10) + DR.4$ + MID$(STRNG$,34,MAX.DESC.LEN)
  2023.       EXIT SUB
  2024. 59922 STRNG$ = DR.4$ + STRNG$
  2025.       EXIT SUB
  2026. 59923 STRNG$ = EMPHASIZE.OFF$ + STRNG$
  2027. 59924 END SUB
  2028. 59930 ' $SUBTITLE: 'CHKCOLOR - highlights based on search string'
  2029. ' $PAGE
  2030. '
  2031. '  NAME    --  CHKCOLOR
  2032. '
  2033. '  INPUTS  --  PARAMETER                   MEANING
  2034. '              LOOK.FOR$           String that triggers highlight
  2035. '              LOOK.IN$            String being searched
  2036. '              END.COLOR$          Terminating color
  2037. '
  2038. '  OUTPUTS --  STRNG$              Revised string
  2039. '
  2040. '  PURPOSE --  Adds highlighting to a string within a string.
  2041. '              Respects previous colorization.
  2042.       SUB CHKCOLOR (LOOK.IN$,LOOK.FOR$,PASSED.END.COLOR$) STATIC
  2043.       IF LOOK.FOR$ = "" THEN _
  2044.          EXIT SUB
  2045.       X$ = LOOK.IN$
  2046.       CALL ALLCAPS (X$)
  2047.       START.COLOR = INSTR(X$,LOOK.FOR$)
  2048.       IF START.COLOR < 1 THEN _
  2049.          EXIT SUB
  2050.       END.COLOR$ = PASSED.END.COLOR$
  2051.       IF END.COLOR$ = "" THEN _
  2052.          END.COLOR$ = EMPHASIZE.OFF$ : _
  2053.          CALL FINDLAST (LEFT$(LOOK.IN$,START.COLOR-1),ESCAPE$,WHERE.FOUND,J) : _
  2054.          IF WHERE.FOUND > 0 THEN _
  2055.             J = INSTR(WHERE.FOUND,LOOK.IN$,"m") : _
  2056.             IF J > 0 THEN _
  2057.                END.COLOR$ = MID$(LOOK.IN$,WHERE.FOUND,J-WHERE.FOUND+1)
  2058.       CALL BRACKET (LOOK.IN$,START.COLOR,START.COLOR + LEN(LOOK.FOR$)-1,EMPHASIZE.ON$,END.COLOR$)
  2059.       END SUB
  2060. 59934 ' $SUBTITLE: 'SETHILITE - subroutine to reset highlight preference'
  2061. ' $PAGE
  2062. '
  2063. '  NAME    --  SETHILITE
  2064. '
  2065. '  INPUTS  --  PARAMETER                   MEANING
  2066. '              SET.TO              New value (True or False)
  2067. '              EMPHASIZE.ON.DEF$   String turns emphasize on
  2068. '              EMPHASIZE.OFF.DEF$  String turns emphasize off
  2069. '
  2070. '  OUTPUTS --  HIGHLIGHT.OFF       Callers preference on Hilite
  2071. '              EMPHASIZE.ON$       String to use for emphasis
  2072. '              EMPHASIZE.OFF$      String to use after emphasis
  2073. '
  2074.       SUB SETHILITE (SET.TO) STATIC
  2075.       HIGHLIGHT.OFF = (EMPHASIZE.ON.DEF$ <> "" AND SET.TO)
  2076.       IF HIGHLIGHT.OFF THEN _
  2077.          EMPHASIZE.ON$ = "" : _
  2078.          EMPHASIZE.OFF$ = "" : _
  2079.          FG.1$ = "" : _
  2080.          FG.2$ = "" : _
  2081.          FG.3$ = "" : _
  2082.          FG.4$ = "" _
  2083.       ELSE EMPHASIZE.ON$ = EMPHASIZE.ON.DEF$ : _
  2084.            FG.1$ = FG.1.DEF$ : _
  2085.            FG.2$ = FG.2.DEF$ : _
  2086.            FG.3$ = FG.3.DEF$ : _
  2087.            FG.4$ = FG.4.DEF$
  2088.       END SUB
  2089. 59940 ' $SUBTITLE: 'COLORPMT - subroutine to colorize prompts'
  2090. ' $PAGE
  2091. '
  2092. '  NAME    --  COLORPMT
  2093. '
  2094. '  INPUTS  --  PARAMETER                   MEANING
  2095. '              STRNG$              String to colorize
  2096. '              HIGHLIGHT.OFF       Whether highlighting is off
  2097. '              EMPHASIZE.ON$       String to use for emphasis
  2098. '              EMPHASIZE.OFF$      String to use after emphasis
  2099. '
  2100. '  OUTPUTS --  STRNG$              Colorized string
  2101. '
  2102. '  PURPOSE -- colorizes a string based on sysop settings
  2103. '             and the string.
  2104. '                        [...] is the default - put in emphasis
  2105. '                        <...> options to type - put in FG.4$
  2106. '                           and first two precedign words use FG.1$ and FG.2$
  2107. '                        options identified on right by ) and on
  2108. '                           left by space or comma - put in FG.4$
  2109. '
  2110.       SUB COLORPMT (STRNG$) STATIC
  2111.       IF HIGHLIGHT.OFF THEN _
  2112.          EXIT SUB
  2113.       ALREADY.COLORIZED = (INSTR(STRNG$,ESCAPE$) > 0)
  2114.       X = INSTR(STRNG$,"<")
  2115.       IF X > 0 THEN _
  2116.          GOTO 59943
  2117.       X = INSTR(STRNG$,"[")   ' highlight default
  2118.       IF X > 0 THEN _
  2119.          Y = INSTR(X,STRNG$,"]") : _
  2120.          IF Y > 0 THEN _
  2121.             CALL BRACKET (STRNG$,X,Y,EMPHASIZE.ON$,EMPHASIZE.OFF$)
  2122.       IF ALREADY.COLORIZED THEN _
  2123.          EXIT SUB
  2124.       X = INSTR(STRNG$,"<")
  2125.       IF X < 1 THEN _
  2126.          GOTO 59945
  2127. 59943 Y = INSTR(X,STRNG$,">")
  2128.       IF Y < 1 THEN _
  2129.          GOTO 59945
  2130.       CALL BRACKET (STRNG$,X,Y,FG.4$,EMPHASIZE.OFF$)
  2131.       Y = INSTR(STRNG$," ")
  2132.       IF Y > 1 AND Y < X THEN _
  2133.          STRNG$ = FG.1$ + STRNG$ : _
  2134.          Z = INSTR(Y+1,STRNG$," ") : _
  2135.          IF Z > 1 AND Z < X+LEN(FG.1$) THEN _
  2136.             STRNG$ = LEFT$(STRNG$,Z) + FG.2.DEF$ + MID$(STRNG$,Z+1)
  2137.       EXIT SUB
  2138. 59945 X = 1
  2139.       DID.INSERT = FALSE
  2140.       L = LEN(FG.4$)
  2141. 59950 Y = INSTR (X,STRNG$,")")  ' x: where command begins, y: terminating pos
  2142.       Z = INSTR (X,STRNG$,",")
  2143.       IF Y = 0 OR (Z > 0 AND Z < Y) THEN _
  2144.          Y = Z
  2145.       K = LEN(STRNG$)
  2146.       IF X > K THEN _
  2147.          EXIT SUB
  2148.       IF Y < 1 THEN _
  2149.          IF NOT DID.INSERT THEN _
  2150.             EXIT SUB _
  2151.          ELSE Y = K+1
  2152.       Z = Y - 1
  2153.       WHILE Z > 0    ' got terminating pos: find beginning
  2154.          IF INSTR(OPTION.END$,MID$(STRNG$,Z,1)) > 0 THEN _
  2155.             X = Z + 1 : _
  2156.             Z = 0
  2157.          Z = Z - 1
  2158.       WEND
  2159.       IF Y-X < 3 THEN _     ' exclude commands too long
  2160.          CMND.STRNG$ = MID$(STRNG$,X,Y-X) : _
  2161.          X$ = CMND.STRNG$ : _
  2162.          CALL ALLCAPS (CMND.STRNG$) : _
  2163.          IF X$ = CMND.STRNG$ THEN _  ' exclude lower case
  2164.             DID.INSERT = TRUE : _
  2165.             CALL BRACKET (STRNG$,X,Y-1,FG.4$,EMPHASIZE.OFF$) : _  ' colorize
  2166.             Y = Y + L
  2167.       X = Y + 1
  2168.       GOTO 59950
  2169.       END SUB
  2170. 59960 ' $SUBTITLE: 'BRACKET - Inserts strings around a string'
  2171. ' $PAGE
  2172. '
  2173. '  NAME    --  BRACKET
  2174. '
  2175. '  INPUTS  --  PARAMETER                   MEANING
  2176. '              STRNG$              Insert in this string
  2177. '              B4.HERE             Insert 1st before this pos
  2178. '              AFTER.HERE          Insert 2nd after this pos
  2179. '              B4.STRNG$           String to insert before
  2180. '              AFTER.STRNG$        String to insert after
  2181. '
  2182. '  OUTPUTS --  STRNG$
  2183. '
  2184. '  PURPOSE -- Primarily for colorization
  2185. '
  2186.       SUB BRACKET (STRNG$,B4.HERE,AFTER.HERE,B4.STRNG$,AFTER.STRNG$) STATIC
  2187.       STRNG$ = LEFT$(STRNG$,B4.HERE-1) + _
  2188.                B4.STRNG$ + _
  2189.                MID$(STRNG$,B4.HERE,AFTER.HERE-B4.HERE+1) + _
  2190.                AFTER.STRNG$ + _
  2191.                RIGHT$(STRNG$,LEN(STRNG$) - AFTER.HERE)
  2192.       END SUB
  2193. 59965 ' $SUBTITLE: 'USERCOLOR - lets user set color for normal text'
  2194. ' $PAGE
  2195. '
  2196. '  NAME    --  USERCOLOR
  2197. '
  2198. '  INPUTS  --  PARAMETER                   MEANING
  2199. '              EMPHASIZE.OFF$      Normal text color
  2200. '
  2201. '  OUTPUTS --  EMPHASIZE.OFF$      New text color
  2202. '              BOLD.TEXT$          Whether bold (0 not, 1 bold)
  2203. '              USER.TEXT.COLOR     ANSI Color selected
  2204. '
  2205. '  PURPOSE --  Lets caller select desired color and whether bold.
  2206. '
  2207.       SUB USERCOLOR STATIC
  2208.       IF HIGHLIGHT.OFF THEN _
  2209.          EXIT SUB
  2210. 59970 CALL QTPUT (EMPHASIZE.OFF$,0)
  2211.       A$ = "Make text R)ed,G)reen,Y)ellow,B)lue,P)urple,C)yan,W)hite" + PRESS.ENTER.EXPERT$
  2212.       GOSUB 59973
  2213.       IF Q = 0 THEN _
  2214.          EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + _
  2215.              ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m" : _
  2216.          EXIT SUB
  2217.       CALL ALLCAPS (B$)
  2218.       X = INSTR("RGYBPCW",B$)
  2219.       IF X = 0 THEN _
  2220.          GOTO 59970
  2221.       USER.TEXT.COLOR = 30 + X
  2222.       A$ = "Make text BOLD (Y,[N])"
  2223.       GOSUB 59973
  2224.       BOLD.TEXT$ = CHR$(48 - YES)
  2225.       EMPHASIZE.OFF$ = ESCAPE$ + "[" + BOLD.TEXT$ + ";40;" + MID$(STR$(USER.TEXT.COLOR),2) + "m"
  2226.       GOTO 59970
  2227. 59973 SUBROUTINE.PARAMETER = 1
  2228.       TURBO.KEY = -TURBO.KEY.USER
  2229.       CALL TGET
  2230.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2231.          EXIT SUB
  2232.       RETURN
  2233.       END SUB
  2234. 59980 ' $SUBTITLE: 'SETUGD - Sets user graphic preference'
  2235. ' $PAGE
  2236. '
  2237. '  NAME    --  SETUGD
  2238. '
  2239. '  INPUTS  --  PARAMETER                   MEANING
  2240. '              GRAPHICS.NUMBER   0=None, 1=Ascii, 2=color
  2241. '
  2242. '  OUTPUTS --  GR                Shared var - set to
  2243. '                                graphics.number
  2244. '              GRAPHICS.LETTER$  What add to file name to
  2245. '                                see if got graphics file ver
  2246. '
  2247. '  PURPOSE --  Sets file graphics preference
  2248. '
  2249.       SUB SETUGD (GRAPHICS.NUMBER,GRAPHICS.LETTER$) STATIC
  2250.       GR = GRAPHICS.NUMBER
  2251.       IF GR = 2 THEN _
  2252.          DR.1$ = FG.1.DEF$ : _
  2253.          DR.2$ = FG.2.DEF$ : _
  2254.          DR.3$ = FG.3.DEF$ : _
  2255.          DR.4$ = FG.4.DEF$ _
  2256.       ELSE DR.1$ = "" : _
  2257.            DR.2$ = "" : _
  2258.            DR.3$ = "" : _
  2259.            DR.4$ = ""
  2260.       GRAPHICS.LETTER$ = MID$(" GC",GR+1, - (GR > 0))
  2261.       END SUB
  2262. 60000 ' $SUBTITLE: 'EOFCOMM - Determines whether input in comm port buffer'
  2263. ' $PAGE
  2264. '
  2265. '  NAME    --  EOFCOMM
  2266. '
  2267. '  INPUTS  --  PARAMETER                   MEANING
  2268. '               FOSSIL              Whether fossil driver used
  2269. '               COMPORT%            Comm port # in use
  2270. '
  2271. '  OUTPUTS --  NOCHARS%           -1 (TRUE) if no chars in buffer.
  2272. '                                             Anything else means has char.
  2273. '
  2274. '  PURPOSE -- Query comm port to see if input waiting
  2275. '
  2276.       SUB EOFCOMM (NOCHARS%) STATIC
  2277.       IF FOSSIL THEN _
  2278.          CALL FOSREADAHEAD(COMPORT%,NOCHARS%) _
  2279.       ELSE NOCHARS% = EOF(3)
  2280.       END SUB
  2281. 60100 ' $SUBTITLE: 'GSANDR - Global search and replace'
  2282. ' $PAGE
  2283. '
  2284. '  NAME    --  GSANDR
  2285. '
  2286. '  INPUTS  --  PARAMETER                   MEANING
  2287. '              STRNG$              String to edit
  2288. '              LOOK.FOR$           String to look for
  2289. '              REPLACE.BY$         String to replace by
  2290. '
  2291. '  OUTPUTS --  STRNG$              Edited string
  2292. '
  2293. '  PURPOSE --  Replaces every occurence of LOOK.FOR$ that
  2294. '                         is in STRNG$ by REPLACE.BY$
  2295. '
  2296.       SUB GSANDR (STRNG$,LOOK.FOR$,REPLACE.BY$,OVERSTRIKE) STATIC
  2297.       IF LOOK.FOR$ = "" THEN _
  2298.          EXIT SUB
  2299.       X = 1
  2300.       L = LEN(REPLACE.BY$)
  2301.       M = LEN(LOOK.FOR$)
  2302. 60102 Y = INSTR(X,STRNG$,LOOK.FOR$)
  2303.       IF Y < 1 THEN _
  2304.          EXIT SUB
  2305.       IF OVERSTRIKE THEN _
  2306.          MID$(STRNG$,Y) = REPLACE.BY$ + SPACE$((L-M)*(L < M)) _
  2307.       ELSE STRNG$ = LEFT$(STRNG$,Y-1) + _
  2308.                     REPLACE.BY$ + _
  2309.                     RIGHT$(STRNG$,LEN(STRNG$)-Y+1-M)
  2310.       X = Y + L
  2311.       IF X > LEN(STRNG$) THEN _
  2312.          EXIT SUB
  2313.       GOTO 60102
  2314.       END SUB
  2315. 60130 ' $SUBTITLE: 'METAGSR -- Meta Global search and replace'
  2316. ' $PAGE
  2317. '
  2318. '  NAME    --  METAGSR
  2319. '
  2320. '  INPUTS  --  PARAMETER               MEANING
  2321. '              STRNG$              String to edit
  2322. '
  2323. '  OUTPUTS --  STRNG$              Edited string
  2324. '
  2325. '  PURPOSE --  Global search and replace for meta variables
  2326. '
  2327.       SUB METAGSR (STRNG$,OVERSTRIKE) STATIC
  2328.       Y = 1
  2329. 60131 IF Y > LEN(STRNG$) THEN _
  2330.          EXIT SUB
  2331.       X = INSTR(Y,STRNG$,"[")
  2332.       IF X = 0 THEN _
  2333.          EXIT SUB
  2334.       Y = INSTR(X,STRNG$,"]")
  2335.       IF Y = 0 THEN _
  2336.          EXIT SUB
  2337.       M = Y-X+1
  2338.       TEMP = Y-X-1
  2339.       CALL CHECKINT(MID$(STRNG$,X+1,TEMP))
  2340.       IF (EC > 0) OR (TESTED.INTEGER.VALUE < 1) OR (TESTED.INTEGER.VALUE > MAX.WORK.VAR) THEN _
  2341.          GOTO 60135
  2342.       IF ((TESTED.INTEGER.VALUE < 10) AND (TEMP = 1)) OR ((TESTED.INTEGER.VALUE > 9) AND (TEMP = 2)) THEN _
  2343.          GOTO 60132
  2344.       Y = X + 1
  2345.       GOTO 60131
  2346. 60132 WORK.HOLD$ = GSR.ARA$(TESTED.INTEGER.VALUE)
  2347.       IF Y = LEN(STRNG$) THEN _
  2348.          GOTO 60151
  2349.       IF MID$(STRNG$,Y+1,1) <> "(" THEN _
  2350.          GOTO 60151
  2351.       I = INSTR(Y+1,STRNG$,")")
  2352.       IF I = 0 THEN _
  2353.          GOTO 60151
  2354.       J = INSTR(Y+1,STRNG$,":")
  2355.       IF J > I THEN _
  2356.          GOTO 60151
  2357.       CALL CHECKINT (MID$(STRNG$,Y+2))
  2358.       IF (EC > 0) OR (TESTED.INTEGER.VALUE < 1) OR _
  2359.          (TESTED.INTEGER.VALUE > LEN(WORK.HOLD$)) THEN _
  2360.             GOTO 60151
  2361.       Y = I
  2362.       M = I-X+1
  2363.       STRT.SUB = TESTED.INTEGER.VALUE
  2364.       CALL CHECKINT (MID$(STRNG$,J+1))
  2365.       IF EC > 0 OR TESTED.INTEGER.VALUE < 1 OR _
  2366.          (TESTED.INTEGER.VALUE > LEN(WORK.HOLD$)) THEN _
  2367.             GOTO 60151
  2368.       LEN.SUB = TESTED.INTEGER.VALUE
  2369.       WORK.HOLD$ = MID$(WORK.HOLD$,STRT.SUB,LEN.SUB)
  2370.       GOTO 60151
  2371. 60135 META.VAL$ = MID$(STRNG$,X+1,Y-X-1)
  2372.       I = INSTR("      BAUD  PORT  PORT# PARITYPROTO NODE  FILE  ",META.VAL$)
  2373.       IF I = 0 OR LEN(META.VAL$) < 4 THEN _                          ' KG071901
  2374.          Y = X + 1 : _
  2375.          GOTO 60131
  2376.       J = (I-1)\6 + 1
  2377.       K = (I+4)\6 + 1
  2378.       IF K > J THEN _
  2379.          EXIT SUB
  2380.       ON J GOTO 60155, _
  2381.                 60137, _
  2382.                 60139, _
  2383.                 60141, _
  2384.                 60143, _
  2385.                 60145, _
  2386.                 60147, _
  2387.                 60149, _
  2388.                 60151
  2389. 60137 WORK.HOLD$ = TALK.TO.MODEM.AT$
  2390.       GOTO 60151
  2391. 60139 WORK.HOLD$ = COM.PORT$
  2392.       GOTO 60151
  2393. 60141 WORK.HOLD$ = MID$(COM.PORT$,4)
  2394.       GOTO 60151
  2395. 60143 WORK.HOLD$ = MID$(BAUD.PARITY$,INSTR(BAUD.PARITY$,",")+1,1)
  2396.       GOTO 60151
  2397. 60145 WORK.HOLD$ = FT$
  2398.       GOTO 60151
  2399. 60147 WORK.HOLD$ = NODE.ID$
  2400.       GOTO 60151
  2401. 60149 IF BATCH.TRANSFER THEN _
  2402.          WORK.HOLD$ = "@" + NODE.WORK.FILE$ _
  2403.       ELSE WORK.HOLD$ = FILE.NAME$
  2404.       GOTO 60151
  2405. 60151 L = LEN(WORK.HOLD$)
  2406.       IF OVERSTRIKE THEN _
  2407.          MID$(STRNG$,X) = WORK.HOLD$ + SPACE$((L-M)*(L < M)) _
  2408.       ELSE STRNG$ = LEFT$(STRNG$,X-1) + WORK.HOLD$ + RIGHT$(STRNG$,LEN(STRNG$)-Y)
  2409.       Y = 1 ' Y = X + L
  2410.       GOTO 60131
  2411. 60155 Y = Y + 1
  2412.       GOTO 60131
  2413.       END SUB
  2414. 60180 ' $SUBTITLE: 'TIMELOCK - Test TIME LOCK for premium features'
  2415. ' $PAGE
  2416. '
  2417. '  NAME    --  TIMELOCK  (written by Doug Azzarito)
  2418. '
  2419. '  INPUTS  --  PARAMETER                   MEANING
  2420. '              TIME.LOCK.SET               SECONDS/SESSION TO LOCK
  2421. '
  2422. '  OUTPUTS --  SUBROUTINE.PARAMETER     -1 if feature is LOCKED
  2423. '
  2424. '  PURPOSE -- Check elapsed time for lock duration
  2425. '
  2426.       SUB TIMELOCK STATIC
  2427.       CALL TIMEREMAIN(TIME.REMAINING!)
  2428.       IF TCA! >= TIME.LOCK.SET THEN _                                ' KG081601
  2429.          OK = TRUE : _
  2430.          EXIT SUB
  2431.       CALL QTPUT1 ("Sorry, " + FIRST.NAME$ + _                       ' KG081601
  2432.                    ", function unavailable for another" + _          ' KG081601
  2433.                    STR$(TIME.LOCK.SET-TCA!) + " seconds")            ' KG081601
  2434.       CALL BUFFILE(HELP.PATH$+"TIMELOCK"+HELP.EXTENSION$,X)
  2435.       OK = FALSE
  2436.       END SUB
  2437. 60200 ' $SUBTITLE: 'MARKTIME - Give feedback for lengthy processes'
  2438. ' $PAGE
  2439. '
  2440. '  NAME    --  MARKTIME
  2441. '
  2442. '  INPUTS  --  PARAMETER                   MEANING
  2443. '              DOT.NUMBER          How many dots printed
  2444. '
  2445. '  OUTPUTS --  DOT.NUMBER
  2446. '
  2447. '  PURPOSE --  Marks time by putting colorized dots out
  2448. '              to 4, then erasing
  2449. '
  2450.       SUB MARKTIME (DOT.NUMBER) STATIC
  2451.       CALL FINDTIME (TI!)
  2452.       IF TI! - PREV.TI! < 1.0 THEN _
  2453.          EXIT SUB
  2454.       PREV.TI! = TI!
  2455.       IF REMOVE.DOT AND DOT.NUMBER > 0 THEN _
  2456.          CALL QTPUT (BACKSPACE$,0) : _
  2457.          DOT.NUMBER = DOT.NUMBER - 1 : _
  2458.          EXIT SUB
  2459.       DOT.NUMBER = DOT.NUMBER + 1
  2460.       ON DOT.NUMBER GOTO 60201,60202,60203,60204
  2461. 60201 X$ = FG.1$
  2462.       REMOVE.DOT = FALSE
  2463.       GOTO 60205
  2464. 60202 X$ = FG.2$
  2465.       GOTO 60205
  2466. 60203 X$ = FG.3$
  2467.       GOTO 60205
  2468. 60204 X$ = FG.4$
  2469.       REMOVE.DOT = TRUE
  2470. 60205 CALL QTPUT (X$ + "." + EMPHASIZE.OFF$,0)
  2471.       END SUB
  2472. 60300 ' $SUBTITLE: 'AUTOPAGE - NOTIFIES SYSOP WHEN SPECIFIC USER CALLS'
  2473. ' $PAGE
  2474. '
  2475. '  NAME    --  AUTOPAGE   'Contributed  by Gregg and Bob Snyder
  2476. '                        'and RoseMarie Siddiqui
  2477. '
  2478. '  INPUTS  --  AUTOPAGE.DEF$  List of conditions that trigger
  2479. '                                       notification and how
  2480. '
  2481. '  OUTPUTS -- NONE
  2482. '
  2483. '  PURPOSE -- Search AUTOPAGE.DEF$ for match on whether
  2484. '             on name, security level, whether new user.
  2485. '             Also controls whether caller notified and
  2486. '             number of times sysop has bell rung.
  2487. '             And what tune to play (if any).
  2488. '
  2489.       SUB AUTOPAGE STATIC
  2490.       CALL FINDIT (AUTOPAGE.DEF$)
  2491.       IF NOT OK THEN _
  2492.          EXIT SUB
  2493.       EC = 0
  2494.       OK = FALSE
  2495.       WHILE NOT EOF(2) AND OK = FALSE AND EC = 0
  2496.          CALL READPARMS (WORK.ARA$(),4,1)
  2497.          IF EC = 0 THEN _
  2498.             OK = (WORK.ARA$(1) = ACTIVE.USER.NAME$) : _
  2499.             IF NOT OK THEN _
  2500.                IF NEW.USER AND WORK.ARA$(1) = "NEWUSER" THEN _
  2501.                   OK = TRUE _
  2502.                ELSE IF LEFT$(WORK.ARA$(1),1) = "/" AND LEN(WORK.ARA$(1)) > 2 THEN _
  2503.                        B = INSTR (2,WORK.ARA$(1),"/") : _
  2504.                        IF B > 0 AND LEN(WORK.ARA$(1)) > B THEN _
  2505.                           IF USER.SECURITY.LEVEL <= VAL(MID$(WORK.ARA$(1),B+1)) AND _
  2506.                              USER.SECURITY.LEVEL >= VAL(MID$(WORK.ARA$(1),2)) THEN _
  2507.                                 OK = TRUE
  2508.       WEND
  2509.       CLOSE 2
  2510.       IF EC > 0 OR NOT OK THEN _
  2511.          EC = 0 : _
  2512.          EXIT SUB
  2513.       PAGE.STATUS$ = "AutoPaged!"
  2514.       IF LEFT$(WORK.ARA$(2),1) = "N" THEN _
  2515.          A$ = "Telling sysop you're on..." : _                       ' KG081501
  2516.          CALL RINGCALLER
  2517.       B = (WORK.ARA$(4) = "")
  2518.       WORK.ARA$(5) = ""
  2519.       FOR I = 1 TO VAL(WORK.ARA$(3))
  2520.          IF B THEN _
  2521.             CALL LPRNT (BELL.RINGER$,0) : _
  2522.          ELSE WORK.ARA$(5) = WORK.ARA$(5) + "O4 X" + VARPTR$(WORK.ARA$(4))
  2523.       NEXT
  2524.       IF NOT B THEN _
  2525.          CALL RBBSPLAY (WORK.ARA$(5))
  2526.       END SUB
  2527. 62520 ' $SUBTITLE: 'PUTMATTR - subroutine to save msg. attributes'
  2528. ' $PAGE
  2529. '
  2530. '  NAME    --  PUTMATTR
  2531. '
  2532. '  INPUTS  --  PARAMETER                   MEANING
  2533. '              Q
  2534. '              B$
  2535. '              LINES.IN.MESSAGE
  2536. '              S
  2537. '              NON.STOP
  2538. '              MESSAGE.DIM.INDEX
  2539. '
  2540. '  OUTPUTS --  SQ
  2541. '              LG$(10)
  2542. '              LINES.IN.MESSAGE.SAVE
  2543. '              SL
  2544. '              NON.STOP.SAVE
  2545. '              MESSAGE.DIM.INDEX.SAVE
  2546. '
  2547. '  PURPOSE --  WHEN REPLYING TO A MESSAGE THIS ROUTINE SAVES
  2548. '              THE ATTRIBUTES OF THE ORGINAL MESSAGE
  2549. '
  2550.       SUB PUTMATTR STATIC
  2551.       SQ = Q
  2552.       LG$(10) = B$
  2553.       LINES.IN.MESSAGE.SAVE = LINES.IN.MESSAGE
  2554.       SL = S
  2555.       NON.STOP.SAVE = NON.STOP
  2556.       MESSAGE.DIM.INDEX.SAVE = MESSAGE.DIM.INDEX
  2557.       END SUB
  2558. 62530 ' $SUBTITLE: 'GETMATTR - subroutine to get msg. attributes'
  2559. ' $PAGE
  2560. '
  2561. '  NAME    --  GETMATTR
  2562. '
  2563. '  INPUTS  --  PARAMETER                   MEANING
  2564. '              SQ
  2565. '              LG$(10)
  2566. '              LINES.IN.MESSAGE.SAVE
  2567. '              SL
  2568. '              NON.STOP.SAVE
  2569. '              MESSAGE.DIM.INDEX.SAVE
  2570. '
  2571. '  OUTPUTS --  Q
  2572. '              B$
  2573. '              LINES.IN.MESSAGESAVE
  2574. '              S
  2575. '              NON.STOP
  2576. '              MESSAGE.DIM.INDEX
  2577. '              KILL.MESSAGE
  2578. '
  2579. '  PURPOSE --  After replying to a message this routine restores
  2580. '              the attributes of the orginal message
  2581. '
  2582.       SUB GETMATTR STATIC
  2583.       Q = SQ
  2584.       B$ = LG$(10)
  2585.       LINES.IN.MESSAGE = LINES.IN.MESSAGE.SAVE
  2586.       S = SL
  2587.       NON.STOP = NON.STOP.SAVE
  2588.       MESSAGE.DIM.INDEX = MESSAGE.DIM.INDEX.SAVE
  2589.       KILL.MESSAGE = FALSE
  2590.       END SUB
  2591. 62540 ' $SUBTITLE: 'RPTTIME -- Reports time on system'
  2592. ' $PAGE
  2593. '
  2594. '  NAME    --  RPTTIME
  2595. '
  2596. '  INPUTS  --  PARAMETER                   MEANING
  2597. '
  2598. '  OUTPUTS --
  2599. '
  2600. '  PURPOSE --  Tells user time used on system
  2601. '
  2602.       SUB RPTTIME STATIC
  2603.       CALL SKIPLINE (1)
  2604.       CALL GETIME                                                    ' KG061203
  2605.       CALL AMORPM
  2606.       QX = ((HHH * 60) + MMM + (SSS / 60.0)) * 10.0
  2607.       Q! = QX / 10.0
  2608.       MINS = (HHH * 60) + MMM
  2609.       CALL CARRIER
  2610.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2611.          EXIT SUB
  2612.       CALL QTPUT1 ("Now: " + DATE$ + " at " + TIME$)
  2613.       CALL QTPUT1 ("On for" + STR$(MINS) + " mins," + STR$(SSS) + " secs")
  2614.       CALL TALK (7,A$)
  2615.       END SUB
  2616. 62600 ' $SUBTITLE: 'PROTOCOL - Determine protocols available'
  2617. ' $PAGE
  2618. '
  2619. '  NAME    -- PROTOCOL
  2620. '
  2621. '  INPUTS  --     PARAMETER                    MEANING
  2622. '                 PROTO.DEF$                File of installed protocols
  2623. '
  2624. '  OUTPUTS -- TRANSFER.OPTIONS$         Prompt for protocol choice
  2625. '             DFLTXFER$                 Letters of protocols
  2626. '             INTERNAL.EQUIV$           Internal protocol to use
  2627. '
  2628. '  PURPOSE -- TO determine what protocols are available to user
  2629. '
  2630.       SUB PROTOCOL STATIC
  2631.       CALL FINDIT (PROTO.DEF$)
  2632.       IF NOT OK THEN _
  2633.          TRANSFER.OPTIONS$ = "A)scii,X)modem,C)rcXmodem,Y)modem" : _
  2634.          INTERNAL.EQUIV$ = "AXCY" : _
  2635.          DFLTXFER$ = "AXCY" : _
  2636.          GOTO 62604
  2637.       DFLTXFER$ = ""
  2638.       INTERNAL.EQUIV$ = ""
  2639.       TRANSFER.OPTIONS$ = ""
  2640.       L = 0
  2641. 62602 IF EOF(2) THEN _
  2642.          GOTO 62604
  2643.       CALL READPARMS (WORK.ARA$(),13,1)
  2644.       IF EC > 0 THEN _
  2645.          EXIT SUB
  2646.       DFLTXFER$ = DFLTXFER$ + " "
  2647.       INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + " "
  2648.       IF USER.SECURITY.LEVEL < VAL(WORK.ARA$(2)) THEN _
  2649.          GOTO 62602
  2650.       IF LEFT$(WORK.ARA$(5),1) = "R" THEN _
  2651.          IF NOT RELIABLE.MODE THEN _
  2652.             GOTO 62602
  2653.       IF LEFT$(WORK.ARA$(3),1) = "I" THEN _
  2654.          GOTO 62603
  2655.       X = INSTR(WORK.ARA$(12)+" "," ")
  2656.       X$ = LEFT$(WORK.ARA$(12),X-1)
  2657.       CALL FINDFILE (X$,FOUND)
  2658.       IF FOUND THEN _
  2659.          X = INSTR(WORK.ARA$(13)+" "," ") : _
  2660.          X$ = LEFT$(WORK.ARA$(13),X-1) : _
  2661.          CALL FINDFILE (X$,FOUND)
  2662.       IF NOT FOUND THEN _
  2663.          GOTO 62602
  2664. 62603 MID$(DFLTXFER$,LEN(DFLTXFER$),1) = LEFT$(WORK.ARA$(1),1)
  2665.       CALL FINDLAST (WORK.ARA$(1),CRLF$,X,I)
  2666.       IF X > 0 AND X >= LEN(WORK.ARA$(1)) - 2 THEN _
  2667.          WORK.ARA$(1) = LEFT$(WORK.ARA$(1),X-1)
  2668.       IF (L + LEN(WORK.ARA$(1)) < 62) AND X = 0 THEN _
  2669.          TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + "," + WORK.ARA$(1) : _
  2670.          L = L + LEN(WORK.ARA$(1)) + 1 _
  2671.       ELSE L = LEN(WORK.ARA$(1)) : _
  2672.            TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + _
  2673.                               CRLF$ + _
  2674.                               WORK.ARA$(1)
  2675.       IF LEFT$(WORK.ARA$(3),1) = "I" AND RIGHT$(WORK.ARA$(3),1) <> "I" THEN _
  2676.          MID$(INTERNAL.EQUIV$,LEN(INTERNAL.EQUIV$),1) = RIGHT$(WORK.ARA$(3),1)
  2677.       GOTO 62602
  2678. 62604 IF INSTR(INTERNAL.EQUIV$,"N") > 0 THEN _
  2679.          GOTO 62605
  2680.       IF X = 0 THEN _
  2681.          TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + ",N)one" _
  2682.       ELSE TRANSFER.OPTIONS$ = TRANSFER.OPTIONS$ + CRLF$ + "N)one"
  2683.       DFLTXFER$ = DFLTXFER$ + "N"
  2684.       INTERNAL.EQUIV$ = INTERNAL.EQUIV$ + "N"
  2685. 62605 IF LEFT$(TRANSFER.OPTIONS$,1) = "," THEN _
  2686.          TRANSFER.OPTIONS$ = MID$(TRANSFER.OPTIONS$,2)
  2687.       IF INSTR(DFLTXFER$,USER.TRANSFER.DEFAULT$) = 0 THEN _
  2688.          CALL QTPUT1 ("Protocol "+USER.TRANSFER.DEFAULT$+" unavailable.  Default reset to None") : _
  2689.          USER.TRANSFER.DEFAULT$ = MID$(DFLTXFER$,INSTR(INTERNAL.EQUIV$,"N"),1)
  2690.       END SUB
  2691. 62620 ' $SUBTITLE: 'TRANSFER - Subroutine for external protocols'
  2692. ' $PAGE
  2693. '
  2694. '  NAME    -- TRANSFER
  2695. '
  2696. '  INPUTS  --     PARAMETER                    MEANING
  2697. '              TRANSFER.FUNCTION         = 1 DOWNLOAD FILE TO USER
  2698. '                                        = 2 UPLOAD FILE TO RBBS-PC
  2699. '              FILE.NAME$                NAME OF FILE FOR TRANSFER
  2700. '              COM.PORT$                 NAME OF COMMUNICATIONS PORT
  2701. '                                        TO BE USED BY KERMIT (COM1
  2702. '                                        OR COM2)
  2703. '              BPS                       = -1 FOR   300 BAUD
  2704. '                                        = -2 FOR   450 BAUD
  2705. '                                        = -3 FOR  1200 BAUD
  2706. '                                        = -4 FOR  2400 BAUD
  2707. '                                        = -5 FOR  4800 BAUD
  2708. '                                        = -6 FOR  9600 BAUD
  2709. '                                        = -7 FOR 19200 BAUD
  2710. '
  2711. '  OUTPUTS  -- NONE
  2712. '
  2713. '  PURPOSE -- To transfer files using external protocols
  2714. '
  2715.       SUB TRANSFER STATIC
  2716.       IF PRIVATE.DOOR THEN _
  2717.          CALL XFRETURN : _
  2718.          EXIT SUB
  2719.       IF TRANSFER.FUNCTION = 1 THEN _
  2720.          B$ = DOWN.TEMPLATE$ : _
  2721.          Z$ = "send " _
  2722.       ELSE IF TRANSFER.FUNCTION = 2 THEN _
  2723.               B$ = UP.TEMPLATE$ : _
  2724.               Z$ = "receive "
  2725.       CALL METAGSR (B$,FALSE)
  2726.       CALL QTPUT1 ("Protocol     : "+PROTO.PROMPT$)
  2727.       CALL QTPUT ("Ready to " + Z$ + " ",0)
  2728.       IF BATCH.TRANSFER THEN _
  2729.          CALL QTPUT1 ("(BATCH)") : _
  2730.          CALL OPENWORK (2,NODE.WORK.FILE$) : _
  2731.          WHILE NOT EOF(2) : _
  2732.            CALL READANY : _
  2733.            CALL BRKFNAME (A$,Z$,Y$,X$,TRUE) : _
  2734.            CALL QTPUT1 ("   "+Y$+X$) : _
  2735.          WEND _
  2736.       ELSE CALL QTPUT1 (FILE.NAME.HOLD$)
  2737.       CALL XFRETURN
  2738.       END SUB
  2739. 62624 ' $SUBTITLE: 'XFRETURN - subroutine to exit as a private door.'
  2740. ' $PAGE
  2741. '
  2742. '  NAME    -- XFRETURN
  2743. '
  2744. '  INPUTS  --     PARAMETER                    MEANING
  2745. '              TRANSFER.FUNCTION         = 1 DOWNLOAD FILE TO USER
  2746. '                                        = 2 UPLOAD FILE TO RBBS-PC
  2747. '                                        = 3 USER REGISTRATION PGM
  2748. '              B$                        NAME OF FILE TO EXIT TO
  2749. '              COM.PORT$                 NAME OF COMMUNICATIONS PORT
  2750. '                                        TO BE USED BY KERMIT (COM1
  2751. '                                        OR COM2)
  2752. '              BPS                       = -1 FOR   300 BAUD
  2753. '                                        = -2 FOR   450 BAUD
  2754. '                                        = -3 FOR  1200 BAUD
  2755. '                                        = -4 FOR  2400 BAUD
  2756. '                                        = -5 FOR  4800 BAUD
  2757. '                                        = -6 FOR  9600 BAUD
  2758. '                                        = -7 FOR 19200 BAUD
  2759. '
  2760. '  OUTPUTS -- NONE
  2761. '
  2762. '  PURPOSE -- To transfer control to another program
  2763. '
  2764.       SUB XFRETURN STATIC
  2765.       IF PRIVATE.DOOR THEN _
  2766.          GOTO 62630
  2767.       IF FAKE.XRPT THEN _
  2768.          CALL FAKEXRPT (FT$)
  2769.       IF ADVANCE.PROTO.WRITE THEN _
  2770.          CALL OPENOUTW ("XFER-"+NODE.ID$+".DEF") : _
  2771.          IF EC < 1 THEN _
  2772.             CALL PRNTWRKA (FILE.NAME$+",,"+FT$) : _
  2773.             CLOSE 2
  2774.       IF PROTO.METHOD$ = "S" THEN _
  2775.          GOTO 62629
  2776. 62628 X$ = LEFT$(B$,INSTR(B$+" "," ")-1)
  2777.       IF X$ = "" THEN _
  2778.          EXIT SUB
  2779.       CALL FINDIT (X$)
  2780.       IF NOT OK THEN _
  2781.          A$ = "Missing door program" : _
  2782.          CALL UPDTCALR (A$ + " " + X$,1) : _
  2783.          SNOOP = TRUE : _
  2784.          CALL LPRNT (A$,1) : _
  2785.          EXIT SUB
  2786.       A$(1) = DISK.FOR.DOS$ + _
  2787.               "COMMAND /C " + _
  2788.               B$
  2789.       A$(2) = RBBS.BAT$
  2790.       PRIVATE.DOOR = TRUE
  2791.       CALL QTPUT1 ("Exiting to External Program for File Transfer")
  2792.       LOCATE 25,1
  2793.       CALL LPRNT(LINE.FEED$,0)
  2794.       CALL RBBSEXIT (A$(),2)
  2795. 62629 CALL SHELLEXIT (B$)
  2796. 62630 IF PRIVATE.DOOR THEN _
  2797.          CALL RESTORECOM : _
  2798.          CALL DELAYIT (7 + BPS) : _
  2799.          CALL QTPUT1 ("Reloading RBBS-PC.  Please be patient.")
  2800. 62631 CALL SKIPLINE (2)
  2801.       LOCATE 24,1
  2802. 62632 END SUB
  2803. 62650 ' $SUBTITLE: 'FAKEXRPT - subroutine to create fake xfer report'
  2804. ' $PAGE
  2805. '
  2806. '  NAME    --  FAKEXRPT
  2807. '
  2808. '  INPUTS  --  PARAMETER                   MEANING
  2809. '              FILE.NAME.HOLD$      FILE TO BE TRANSFERRED
  2810. '              PROTO.USED$          PROTOCOL USED
  2811. '
  2812. '  OUTPUTS --  WRITES OUT TRANSFER FILE REPORT
  2813. '
  2814. '  PURPOSE --  External protocol drivers that do not write
  2815. '              out a standard transfer report must have one
  2816. '              provided in order for "dooring" to external
  2817. '              protocols to work properly, since this file
  2818. '              is read upon returning from an external protocol.
  2819. '
  2820.       SUB FAKEXRPT (PROTO.USED$) STATIC
  2821.       CLOSE 2
  2822.       OPEN "O",2,"XFER-" + _
  2823.                  NODE.FILE.ID$ + _
  2824.                  ".DEF"
  2825.       PRINT #2,FILE.NAME$
  2826.       PRINT #2,
  2827.       PRINT #2,PROTO.USED$
  2828.       PRINT #2,"S"
  2829.       CLOSE 2
  2830.       END SUB
  2831. 62660 ' $SUBTITLE: 'SETEXPERT - subroutine to adjust for expert change'
  2832. ' $PAGE
  2833. '
  2834. '  NAME    --  SETEXPERT
  2835. '
  2836. '  INPUTS  --  PARAMETER                   MEANING
  2837. '              EXPERT.USER          WHETHER IS AN EXPERT
  2838. '
  2839. '  OUTPUTS --  MORE.PROMPT$         Pause prompt
  2840. '              PRESS.ENTER$         Prompt to press enter
  2841. '
  2842. '  PURPOSE --  External protocol drivers that do not write
  2843. '              out a standard transfer report must have one
  2844. '              provided in order for "DOORING" to external
  2845. '              protocols to work properly, since this file
  2846. '              is read upon returning from an external protocol.
  2847. '
  2848.       SUB SETEXPERT STATIC
  2849.       IF EXPERT.USER THEN _
  2850.          MORE.PROMPT$ = "More <[Y],N,C,A" : _
  2851.          PRESS.ENTER$ = PRESS.ENTER.EXPERT$ : _
  2852.          EXIT SUB
  2853.       MORE.PROMPT$ = "More [Y]es,N)o,C)ontinuous,A)bort"
  2854.       PRESS.ENTER$ = PRESS.ENTER.NOVICE$
  2855.       END SUB
  2856. 62668 ' $SUBTITLE: 'NEWPASWRD - subroutine to get new password'
  2857. ' $PAGE
  2858. '
  2859. '  NAME    --  NEWPASWRD
  2860. '
  2861. '  INPUTS  --  PARAMETER                   MEANING
  2862. '              PRMPT$               Prompt to display
  2863. '              DISALLOW.SPACES      Whether answer can have all spaces
  2864. '
  2865. '  OUTPUTS --  Z$                   Password
  2866. '
  2867. '  PURPOSE --  To get a new password.
  2868. '
  2869.       SUB NEWPASWRD (PRMPT$,DISALLOW.SPACES) STATIC
  2870. 62670 A$ = PRMPT$
  2871.       HIDDEN = TRUE
  2872.       SUBROUTINE.PARAMETER = 1
  2873.       CALL TGET
  2874.       HIDDEN = FALSE
  2875.       IF SUBROUTINE.PARAMETER < 0 OR Q = 0 THEN _
  2876.          EXIT SUB
  2877.       IF LEN(B$) > 15 THEN _
  2878.          CALL QTPUT1 ("15 chars max") : _
  2879.          GOTO 62670
  2880.       IF INSTR(B$,";") > 0 THEN _
  2881.          CALL QTPUT1 ("Cannot use ';'") : _
  2882.          GOTO 62670
  2883.       IF DISALLOW.SPACES THEN _
  2884.          IF B$ = SPACE$(LEN(B$)) THEN _
  2885.             CALL QTPUT1 ("Not all blanks") : _
  2886.             GOTO 62670
  2887.       CALL ALLCAPS (B$)
  2888.       Z$ = B$
  2889.       END SUB
  2890. 63000 ' $SUBTITLE: 'TIMEDOUT - exits based on time of day'
  2891. ' $PAGE
  2892. '
  2893. '  NAME    --  TIMEDOUT
  2894. '
  2895. '  INPUTS  --  PARAMETER                   MEANING
  2896. '              RCTTY.BAT$
  2897. '              NODE.RECORD.INDEX
  2898. '              MESSAGE.RECORD$
  2899. '              MODEM.INIT.BAUD$
  2900. '              MODEM.GO.OFFHOOK.COMMADN$
  2901. '
  2902. '  OUTPUTS --  NONE
  2903. '
  2904. '  PURPOSE --  When RBBS-PC is to exit to DOS at a specific time of
  2905. '              day, this routine writes out to the file specified
  2906. '              in "RCTTY.BAT$" the one-line entry:
  2907. '                          RBBSxTM.BAT
  2908. '               WHERE "x" is the node id.
  2909. '
  2910.       SUB TIMEDOUT STATIC
  2911.       FIELD #1,128 AS MESSAGE.RECORD$
  2912.       SUBROUTINE.PARAMETER = 3
  2913.       CALL FILELOCK
  2914.       GET 1,NODE.RECORD.INDEX
  2915.       X$ = DATE$
  2916.       CALL CSTRDATE (X$,Y$)
  2917.       MID$(MESSAGE.RECORD$,77,2) = Y$
  2918.       'MID$(MESSAGE.RECORD$,86,5) = LEFT$(TIME$,5)
  2919.       PUT 1,NODE.RECORD.INDEX
  2920.       SUBROUTINE.PARAMETER = 2
  2921.       CALL FILELOCK
  2922.       CLOSE 2
  2923.       CALL BRKFNAME(CALLERS.FILE$,X$,Y$,Z$,TRUE)
  2924.       FILE.NAME$ = X$ + "RBBS" + NODE.FILE.ID$ + "TM.DEF"
  2925.       OPEN "O",2,FILE.NAME$
  2926.       PRINT #2,MID$(FILE.NAME$,3,7)
  2927.       CLOSE 2
  2928.       IF LOCAL.USER.MODE THEN _
  2929.          EXIT SUB
  2930.       IF SUBROUTINE.PARAMETER <> 7 THEN _
  2931.          SUBROUTINE.PARAMETER = 4 : _
  2932.          CALL FILELOCK : _
  2933.          CALL OPENCOM(MODEM.INIT.BAUD$,",N,8,1")
  2934.       CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$)
  2935.       IF MULTI.LINK.PRESENT <> 0 THEN _
  2936.          CALL DELAYIT (3)
  2937.       END SUB
  2938. 64003 ' $SUBTITLE: 'ASKUSERS - subroutine to get registration information'
  2939. ' $PAGE
  2940. '
  2941. '  NAME    --  ASKUSERS  (WRITTEN BY JON MARTIN)
  2942. '
  2943. '  INPUTS  --  PARAMETER                   MEANING
  2944. '              FILE.NAME$           NAME OF THE FILE CONTAINING THE
  2945. '                                   SCRIPT TO BE USED WHEN ASKING
  2946. '                                   THE USER QUESTIONS.
  2947. '              ACTIVE.USER.NAME$    NAME OF THE CURRENT USER
  2948. '              USER.SECURITY.LEVEL  USER'S SECURITY
  2949. '              UPPER.CASE           SET IF USER NEEDS UPPERCASE
  2950. '
  2951. '  OUTPUTS --  WRITE THE USER'S RESPONSES TO THE QUESTIONS TO THE
  2952. '              FILE NAME SPECIFIED AS THE FIRST PARAMETER IN THE
  2953. '              FIRST RECORD OF THE FILE CONTAINING THE SCRIPT TO
  2954. '              BE USED.
  2955. '              USER.SECURITY.LEVEL  CAN BE RAISED OR LOWERED
  2956. '
  2957. '  PURPOSE --  Provides a sophisticated, script driven mechanism by
  2958. '              which a sysop can solicit information from new users
  2959. '              (via a script that requests registration information
  2960. '              and which can raise or lower his default security
  2961. '              level based on the responses) or ask a questions of
  2962. '              when the user logs off.  The former occurs if the
  2963. '              file "RBBS-REG.DEF" containing the registration
  2964. '              script exists on the same drive as the "WELCOME".
  2965. '              The later exists if the file "EPILOG.DEF" exists on
  2966. '              the same drive as the "WELCOME".
  2967. '
  2968.       SUB ASKUSERS STATIC
  2969.       QUESTIONNAIRE.ABORTED = FALSE
  2970.       QUESTIONNAIRE.CHAIN.STARTED = FALSE                            ' KG060301
  2971.       REDIM A$(256)
  2972.       REDIM WORK.ARA$(MAX.WORK.VAR),GSR.ARA$(MAX.WORK.VAR)
  2973.       PREV.APPEND$ = ""                                              ' MZ060301
  2974. '
  2975. '
  2976. ' *  LOAD SCRIPT CONTAINING THE QUESTIONS INTO THE A$ DIMENSION  *
  2977. '
  2978. '
  2979. 64005 CHAT.AVAILABLE = FALSE
  2980.       QUESTIONNAIRE.CHAIN = FALSE
  2981.       LAST.QUES = 0
  2982.       CALL GRAPHIC (USER.GRAPHIC.DEFAULT$,FILE.NAME$)                ' KG060301
  2983.       IF NOT OK THEN _                                               ' KG060301
  2984.          EXIT SUB                                                    ' KG060301
  2985.       CALL READPARMS (A$(),2,1)
  2986.       IF EC > 0 THEN _
  2987.          EXIT SUB
  2988.       PREV.APPEND$ = APPEND.FILE.NAME$                               ' MZ060301
  2989.       APPEND.FILE.NAME$ = A$(1)
  2990.       MAXIMUM.SECURITY.LEVEL = VAL(A$(2))
  2991.       X = INSTR(A$(2)," ")
  2992.       IF X > 0 THEN _
  2993.          IF USER.SECURITY.LEVEL < VAL(MID$(A$(2),X)) THEN _
  2994.             CALL QTPUT1 ("Higher security needed for this questionnaire") : _
  2995.             EXIT SUB
  2996. '
  2997. '
  2998. ' *  THE FIRST RECORD OF THE SCRIPT FILE CONTAINS THREE PARAMETERS:
  2999. ' *   1.  THE NAME OF THE FILE TO APPEND THE ANSWERS TO.
  3000. ' *   2.  THE MAXIMUM SECURITY LEVEL THE + COMMAND CAN RAISE A USER SECURITY
  3001. ' *   3.  THE MINIMUM SECURITY TO USE THIS QUESTIONNAIRE
  3002. ' * e.g. 'C:XXX.DAT,6 5' writes answers to C:XXX.DAT, can raise to 6,
  3003. ' *      and requires security 5 or more to access
  3004.       SCRIPT.INDEX = 1
  3005.       A$(SCRIPT.INDEX) = ACTIVE.USER.NAME$ + _
  3006.                          " " + _
  3007.                          DATE$ + _
  3008.                          " " + _
  3009.                          TIME$
  3010. 64010 IF EOF(2) OR SCRIPT.INDEX > 255 THEN _
  3011.          GOTO 64100
  3012.       SCRIPT.INDEX = SCRIPT.INDEX + 1
  3013.       LINE INPUT #2,A$(SCRIPT.INDEX)
  3014.       IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _
  3015.          CALL ALLCAPS (A$(SCRIPT.INDEX)) : _
  3016.          CALL TRIM (A$(SCRIPT.INDEX))
  3017.       IF UPPER.CASE THEN _
  3018.          CALL ALLCAPS (A$(SCRIPT.INDEX))
  3019.       IF LEFT$(A$(SCRIPT.INDEX),1) = "?" THEN _
  3020.          SCRIPT.INDEX = SCRIPT.INDEX + 1 : _
  3021.          A$(SCRIPT.INDEX) = "!"
  3022.       GOTO 64010
  3023. '
  3024. '
  3025. ' *  PROCESS QUESTIONS IN THE SCRIPT AS FOLLOWS:
  3026. ' *
  3027. ' * FIRST COLUMN     MEANING
  3028. ' *      :        THIS LINE IS A LABEL THAT MAY BE BRANCHED TO
  3029. ' *      !        THIS MEANS THIS IS AN ANSWER
  3030. ' *      >        THIS IS A "GOTO" COMMAND TO ONE OF THE LABELS
  3031. ' *      *        THIS MEANS THE LINE IS A MESSAGE TO BE WRITTEN TO THE USER
  3032. ' *      ?        THIS MEANS THIS IS A QUESTION FOR THE USER
  3033. ' *      =        THIS MEANS THAT THIS LINE CONTAINS DECISION CRITERIA
  3034. ' *      -        THIS MEANS TO LOWER THE USER'S SECURITY LEVEL
  3035. ' *      +        THIS MEANS TO RAISE THE USER'S SECURITY LEVEL
  3036. ' *      @        THIS MEANS TO ABORT THE QUESTIONNAIRE DO NOT WRITE OUT
  3037. ' *      &        THIS MEANS TO CHAIN TO ANOTHER QUESTIONNAIRE
  3038. ' *      M        Execute specified macro
  3039. ' *      T        Turbo Key
  3040. ' *      <        Assign value to work variable
  3041. '
  3042. 64100 SCRIPT.MAX = SCRIPT.INDEX
  3043.       SCRIPT.INDEX = 1
  3044. 64110 CALL CARRIER
  3045.       IF SUBROUTINE.PARAMETER = -1 THEN _
  3046.          GOTO 64510                                                  ' KG081001
  3047.       SCRIPT.INDEX = SCRIPT.INDEX + 1
  3048.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  3049.          GOTO 64400
  3050.       A$ = MID$(A$(SCRIPT.INDEX),2)
  3051.       X = FALSE
  3052.       IF LEFT$(A$,3) = "/FL" THEN _
  3053.          A$ = RIGHT$(A$,LEN(A$)-3) : _
  3054.          X = TRUE
  3055.       CALL METAGSR (A$,X)
  3056.       CALL SMARTTXT (A$,FALSE,X)
  3057.       X$ = A$
  3058.       ON INSTR(" :!@MT><*?=-+&",LEFT$(A$(SCRIPT.INDEX),1)) GOTO _    ' KG081001
  3059.          64111, _       ' catch invalid lines
  3060.          64110, _       ' : label
  3061.          64110, _       ' ! stored answer
  3062.          64420, _       ' @ abort
  3063.          64120, _       ' M macro execute
  3064.          64430, _       ' T turbo key
  3065.          64440, _       ' > goto label
  3066.          64190, _       ' < assign value
  3067.          64450, _       ' * display line
  3068.          64113, _       ' ? prompt for answer
  3069.          64114, _       ' = conditional branch
  3070.          64460, _       ' - decrease security level
  3071.          64465, _       ' + increase security level
  3072.          64470          ' & chain
  3073. 64111 A$ = "Invalid line.  Column 1 is <" + LEFT$(A$(SCRIPT.INDEX),1)+">.  Must be: * ? = + - > @ & M T <" ' KG081001
  3074.       SUBROUTINE.PARAMETER = 5                                       ' KG081001
  3075.       CALL TPUT                                                      ' KG081001
  3076.       GOTO 64510                                                     ' KG081001
  3077. 64113 LAST.QUES = SCRIPT.INDEX  ' process ?                          ' KG081001
  3078.       GOSUB 64180
  3079.       SUBROUTINE.PARAMETER = 1
  3080.       CALL TGET
  3081.       IF SUBROUTINE.PARAMETER = -1 THEN _
  3082.          GOTO 64510 _
  3083.       ELSE IF Q = 0 THEN _
  3084.               A$ = X$ : _
  3085.               GOTO 64113 _
  3086.            ELSE A$(SCRIPT.INDEX + 1) = "!" + _
  3087.                                        B$ : _
  3088.                 GSR.ARA$(TESTED.INTEGER.VALUE) = B$
  3089.       GOTO 64110
  3090. 64114 IF LEFT$(A$(SCRIPT.INDEX),2) = "=#" THEN _       ' NUMERIC
  3091.          GOSUB 64350 : _
  3092.          GOTO 64110                                                  ' KG081001
  3093.       GOSUB 64300             ' process =                            ' KG081001
  3094.       GOTO 64445                                                     ' KG083003
  3095. 64120 Z$ = MID$(A$(SCRIPT.INDEX),2)   ' Execute macro
  3096.       CALL TRIM (Z$)                                                 ' KG062801
  3097.       CALL ACHKMAC (Z$,FOUND)                                        ' KG062801
  3098.       IF FOUND THEN _                                                ' KG062801
  3099.           CALL FDMACEXE                                              ' KG062801
  3100.       GOTO 64110
  3101. 64180 CALL CHECKINT (A$)
  3102.       IF (EC > 0) OR (TESTED.INTEGER.VALUE < 1) OR _
  3103.           (TESTED.INTEGER.VALUE > MAX.WORK.VAR) OR _
  3104.           (INSTR("123456789",LEFT$(A$,1)) = 0) THEN _
  3105.              TESTED.INTEGER.VALUE = 0 _
  3106.       ELSE A$ = RIGHT$(A$,LEN(A$)-1+(TESTED.INTEGER.VALUE > 9))
  3107.       RETURN
  3108. 64190 GOSUB 64180
  3109.       IF TESTED.INTEGER.VALUE > 0 THEN _
  3110.          GSR.ARA$(TESTED.INTEGER.VALUE) = MID$(A$,2)
  3111.       GOTO 64110
  3112. '
  3113. '
  3114. ' *  SEARCH FOR GOTO LABEL
  3115. '
  3116. '
  3117. 64200 SCRIPT.INDEX = 1
  3118.       CALL METAGSR (BRANCH.LABEL$,FALSE)
  3119.       CALL SMARTTXT (BRANCH.LABEL$,FALSE,FALSE)
  3120.       CALL ALLCAPS (BRANCH.LABEL$)
  3121.       CALL TRIM (BRANCH.LABEL$)
  3122. 64210 SCRIPT.INDEX = SCRIPT.INDEX + 1
  3123.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  3124.          A$ = BRANCH.LABEL$ + _
  3125.               " not found!" : _
  3126.          SUBROUTINE.PARAMETER = 5 : _
  3127.          CALL TPUT : _
  3128.          IF SUBROUTINE.PARAMETER = -1 THEN _
  3129.             RETURN _
  3130.          ELSE IF LAST.QUES > 0 THEN _
  3131.                  SCRIPT.INDEX = LAST.QUES - 1 : _
  3132.                  RETURN _
  3133.               ELSE GOTO 64510                                        ' KG081001
  3134.       IF LEFT$(A$(SCRIPT.INDEX),1) <> ":" THEN _
  3135.          GOTO 64210
  3136.       IF MID$(A$(SCRIPT.INDEX),2) <> BRANCH.LABEL$ THEN _
  3137.          GOTO 64210
  3138.       RETURN
  3139. '
  3140. '
  3141. ' *  DETERMINE BRANCH LOGIC
  3142. '
  3143. '
  3144. 64300 CURRENT.EQUALS = 1
  3145.       Z$ = RIGHT$(A$(LAST.QUES + 1),1)
  3146.       CALL ALLCAPS (Z$)
  3147. 64310 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
  3148.       IF NEXT.EQUALS = 0 THEN _
  3149.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
  3150.          GOTO 64320
  3151.       IF Z$ <> _
  3152.          MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 1,1) THEN  _
  3153.          CURRENT.EQUALS = NEXT.EQUALS : _
  3154.          GOTO 64310
  3155.       BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
  3156. 64320 GOSUB 64200
  3157.       RETURN
  3158. '
  3159. '
  3160. ' *  DETERMINE NUMERIC BRANCH LOGIC
  3161. '
  3162. '
  3163. 64350 CURRENT.EQUALS = 1
  3164. 64360 NEXT.EQUALS = INSTR(CURRENT.EQUALS + 1, A$(SCRIPT.INDEX),"=")
  3165.       IF NEXT.EQUALS = 0 THEN _
  3166.          BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2) : _
  3167.          GOTO 64380
  3168.       NUMERIC = TRUE
  3169.       LOOP.INDEX = 2
  3170.       WHILE LOOP.INDEX < LEN(A$(SCRIPT.INDEX - 1)) +1
  3171.          IF INSTR("()1234567890- ",MID$(A$(SCRIPT.INDEX - 1),LOOP.INDEX,1)) THEN _
  3172.             GOTO 64370
  3173.          NUMERIC = FALSE
  3174. 64370    LOOP.INDEX = LOOP.INDEX + 1
  3175.       WEND
  3176.       IF NOT NUMERIC THEN _
  3177.          CURRENT.EQUALS = NEXT.EQUALS : _
  3178.          GOTO 64360
  3179.       BRANCH.LABEL$ = MID$(A$(SCRIPT.INDEX),CURRENT.EQUALS + 2,NEXT.EQUALS-(CURRENT.EQUALS + 2))
  3180. 64380 GOSUB 64200
  3181.       RETURN
  3182. '
  3183. '
  3184. ' *  WRITE RESPONSES TO DESIGNATED FILE
  3185. '
  3186. '
  3187. 64400 SCRIPT.INDEX = 0
  3188.       EN$ = APPEND.FILE.NAME$
  3189.       CALL LOCKAPPND
  3190.       IF EC <> 0 THEN _
  3191.          A$ = "Fatal Error in script!" : _
  3192.          SUBROUTINE.PARAMETER = 5 : _
  3193.          CALL TPUT : _
  3194.          GOTO 64500
  3195. 64410 SCRIPT.INDEX = SCRIPT.INDEX + 1
  3196.       IF SCRIPT.INDEX > SCRIPT.MAX THEN _
  3197.          GOTO 64500
  3198.       IF LEFT$(A$(SCRIPT.INDEX),1) = ":" THEN _
  3199.          QUESTION.SAVE$ = MID$(A$(SCRIPT.INDEX),2) : _
  3200.          GOTO 64410
  3201.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" AND _
  3202.          LEN(A$(SCRIPT.INDEX)) < 2 THEN _
  3203.          GOTO 64410
  3204.       IF LEFT$(A$(SCRIPT.INDEX),1) = "!" THEN _
  3205.          CALL PRNTWRKA (QUESTION.SAVE$) : _
  3206.          CALL PRNTWRKA (MID$(A$(SCRIPT.INDEX),2))
  3207.       IF SCRIPT.INDEX = 1 AND _
  3208.          APPEND.FILE.NAME$ <> PREV.APPEND$ THEN _                    ' MZ060301
  3209.          CALL PRNTWRKA (A$(SCRIPT.INDEX))
  3210.       IF EC <> 0 THEN _
  3211.          A$ = "Unrecoverable failure in script!" : _
  3212.          SUBROUTINE.PARAMETER = 5 : _
  3213.          CALL TPUT : _
  3214.          GOTO 64500
  3215.       GOTO 64410
  3216. 64420 QUESTIONNAIRE.ABORTED = TRUE  ' @ abort                        ' KG081001
  3217.       GOTO 64510                                                     ' KG081001
  3218. 64430 TURBO.KEY = -TURBO.KEY.USER   ' T turbo key                    ' KG081001
  3219.       GOTO 64110                                                     ' KG081001
  3220. 64440 BRANCH.LABEL$ = A$            ' = branch                       ' KG081001
  3221.       GOSUB 64200                                                    ' KG081001
  3222. 64445 IF SUBROUTINE.PARAMETER = -1 THEN _                            ' KG081001
  3223.          GOTO 64510 _                                                ' KG081001
  3224.       ELSE GOTO 64110                                                ' KG081001
  3225. 64450 SUBROUTINE.PARAMETER = 5      ' * display                      ' KG081001
  3226.       CALL TPUT                                                      ' KG081001
  3227.       GOTO 64445                                                     ' KG081001
  3228. 64460 X = -1        ' - lower security                               ' KG081001
  3229. 64462 CALL CHECKINT (A$)
  3230.       IF EC = 0 THEN _                                               ' KG083104
  3231.          TEMP = USER.SECURITY.LEVEL + _                              ' KG083104
  3232.             X * TESTED.INTEGER.VALUE : _                             ' KG083104
  3233.          IF TEMP <= MAXIMUM.SECURITY.LEVEL THEN _                    ' KG083104
  3234.             USER.SECURITY.LEVEL = TEMP : _                           ' KG083104
  3235.             USER.SECURITY.SAVE = USER.SECURITY.LEVEL : _             ' KG083104
  3236.             ADJUSTED.SECURITY = TRUE                                 ' KG083104
  3237.       GOTO 64110                                                     ' KG081001
  3238. 64465 X = 1               ' + raise security                         ' KG083104
  3239.       GOTO 64462                                                     ' KG083104
  3240. 64470 QUESTIONNAIRE.CHAIN = TRUE  ' & chain questionnaires           ' KG081001
  3241.       FILE.NAME.HOLD$ = A$                                           ' KG081001
  3242.       GOTO 64110                                                     ' KG081001
  3243. 64500 CALL UNLKAPPND
  3244.       CALL CARRIER
  3245.       IF QUESTIONNAIRE.CHAIN THEN _
  3246.          QUESTIONNAIRE.CHAIN.STARTED = TRUE : _
  3247.          FILE.NAME$ = FILE.NAME.HOLD$ : _
  3248.          GOTO 64005
  3249. 64510 CHAT.AVAILABLE = (INSTR("MUF",ACTIVE.MENU$) > 0)
  3250.       OK = TRUE
  3251.       END SUB
  3252. 64600 ' $SUBTITLE: 'VIEWARC - subroutine to display .ARC contents'
  3253. ' $PAGE
  3254. '
  3255. '  NAME    --  VIEWARC  (Written by Jon Martin)
  3256. '
  3257. '  INPUTS  --  PARAMETER                   MEANING
  3258. '              FILE.NAME$           NAME OF THE ARC FILE TO BE
  3259. '                                      VIEWED.
  3260. '
  3261. '  OUTPUTS --  NONE
  3262. '
  3263. '  PURPOSE --  Provides a mechanism to provide users with the
  3264. '              contents of a libraried file prior to downloading.
  3265. '
  3266.       SUB VIEWARC STATIC
  3267.       CLOSE 2
  3268.       IF TURBO.RBBS THEN _
  3269.          RETCODE% = 0
  3270. 'Maple Street Zip View Mods ***********
  3271. IF LAST.EXT$ = "ZIP" THEN _
  3272.    FILNAME$ = LIBRARY.ARCHIVE.PATH$+"PKUNZIP.EXE" _    'PE/03/28/89
  3273. ELSE _
  3274.   FILNAME$ = LIBRARY.ARCHIVE.PATH$+"ARCVIEW.COM"       'PE/03/28/89
  3275.  CALL FINDIT (FILNAME$)
  3276.  IF NOT OK THEN _
  3277.   CALL QTPUT(" Missing Viewarc Utility...Please tell Sysop " ,1) : _
  3278.  EXIT SUB
  3279. '
  3280. CALL QTPUT ("Creating View file, One Moment Please.... ",1)
  3281. IF LAST.EXT$ = "ZIP" THEN _
  3282.  STOP.INTERRUPTS = TRUE : _
  3283.    SHOWARC$ = LIBRARY.ARCHIVE.PATH$+ "PKUNZIP.EXE -v "_
  3284.  ELSE _
  3285.     SHOWARC$ = LIBRARY.ARCHIVE.PATH$+ "ARCVIEW.COM "
  3286. '
  3287. SHOWARC$ = SHOWARC$ +FILE.NAME$ + ">" + ARC.WORK$
  3288.  SHELL SHOWARC$
  3289.  CALL BUFFILE (ARC.WORK$,X)
  3290.  EXIT SUB
  3291. ' *** Code Below is orig RBBS 17C ***********
  3292.       IF SHARE.IT THEN _
  3293.          OPEN FILE.NAME$ FOR RANDOM SHARED AS #2 LEN=1 _
  3294.       ELSE OPEN "R",2,FILE.NAME$,1
  3295.       FIELD 2,1 AS CHAR$
  3296.       BYTE.POINTER! = 1
  3297.       ARC.END! = LOF(2)
  3298. 64605 IF BYTE.POINTER! > ARC.END! THEN _
  3299.          GOTO 64620
  3300.       GET 2,BYTE.POINTER!
  3301.       IF CHAR$ <> CHR$(26) THEN _
  3302.          GOTO 64620
  3303.       BYTE.POINTER! = BYTE.POINTER! + 1
  3304.       GET 2,BYTE.POINTER!
  3305.       IF CHAR$ = CHR$(0) THEN _
  3306.          GOTO 64620
  3307.       ARCED.NAME$ = ""
  3308.       FOR X = 1 TO 12
  3309.          GET 2,BYTE.POINTER! + X
  3310.          IF CHAR$ < CHR$(40) THEN _
  3311.             GOTO 64610
  3312.          ARCED.NAME$ = ARCED.NAME$ + _
  3313.                        CHAR$
  3314.       NEXT
  3315. 64610 A$ = ARCED.NAME$
  3316.       BYTE.POINTER! = BYTE.POINTER! + 14
  3317.       GOSUB 64630
  3318.       TOTAL.BYTES# = WORK.BYTES#
  3319.       BYTE.POINTER! = BYTE.POINTER! + 10
  3320.       GOSUB 64630
  3321.       FINAL.BYTES# = WORK.BYTES#
  3322.       A$ = A$ + _
  3323.            SPACE$(20 - LEN(ARCED.NAME$) - LEN(STR$(FINAL.BYTES#))) + _
  3324.            STR$(FINAL.BYTES#) + _
  3325.            " bytes."
  3326.       CALL QTPUT1 (A$)
  3327.       BYTE.POINTER! = BYTE.POINTER! + TOTAL.BYTES# + 4
  3328.       GOTO 64605
  3329. 64620 CLOSE 2
  3330.       SUBROUTINE.PARAMETER = 0
  3331.       CALL CARRIER
  3332.       A$ = ""
  3333.       EXIT SUB
  3334. 64630 FACTOR# = 1#
  3335.       WORK.BYTES# = 0
  3336.       FOR X = 0 TO 3
  3337.          GET 2,BYTE.POINTER! + X
  3338.          WORK.BYTES# = WORK.BYTES# + FACTOR# * ASC(CHAR$)
  3339.          FACTOR# = FACTOR# * 256#
  3340.       NEXT
  3341.       RETURN
  3342.       END SUB
  3343.